Line data Source code
1 : !> \file mo_orderpack.f90
2 : !> \brief \copybrief mo_orderpack
3 : !> \details \copydetails mo_orderpack
4 :
5 : !> \brief Sort and ranking routines
6 : !> \details
7 : !! This module is the Orderpack 2.0 from Michel Olagnon.
8 : !! It provides order and unconditional, unique, and partial
9 : !! ranking, sorting, and permutation.
10 : !!
11 : !! <b> Unconditional ranking </b>
12 : !!
13 : !! \code{.f90} subroutine MRGRNK (XVALT, IMULT) \endcode
14 : !!
15 : !! Ranks array XVALT into index array IRNGT, using merge-sort.
16 : !! For performance reasons, the first 2 passes are taken out of the
17 : !! standard loop, and use dedicated coding.
18 : !!
19 : !! \code{.f90} subroutine MRGREF (XVALT, IRNGT) \endcode
20 : !!
21 : !! Ranks array XVALT into index array
22 : !! IRNGT, using merge-sort. This version is not optimized for performance,
23 : !! and is thus not as difficult to read as the previous one.
24 : !!
25 : !! <b> Partial ranking </b>
26 : !!
27 : !! \code{.f90} subroutine RNKPAR (XVALT, IRNGT, NORD) \endcode
28 : !!
29 : !! Ranks partially XVALT by IRNGT,
30 : !! up to order NORD (refined for speed). This routine uses a pivoting
31 : !! strategy such as the one of finding the median based on the quicksort
32 : !! algorithm, but we skew the pivot choice to try to bring it to NORD as
33 : !! fast as possible. It uses 2 temporary arrays, one where it stores the
34 : !! indices of the values smaller than the pivot, and the other for the
35 : !! indices of values larger than the pivot that we might still need later
36 : !! on. It iterates until it can bring the number of values in ILOWT to
37 : !! exactly NORD, and then uses an insertion sort to rank this set, since
38 : !! it is supposedly small.
39 : !!
40 : !! \code{.f90} subroutine RAPKNR (XVALT, IRNGT, NORD) \endcode
41 : !!
42 : !! Same as RNKPAR, but in
43 : !! decreasing order (RAPKNR = RNKPAR spelt backwards).
44 : !!
45 : !! \code{.f90} subroutine REFPAR (XVALT, IRNGT, NORD) \endcode
46 : !!
47 : !! Ranks partially XVALT by IRNGT,
48 : !! up to order NORD This version is not optimized for performance, and is
49 : !! thus not as difficult to read as some other ones. It uses a pivoting
50 : !! strategy such as the one of finding the median based on the quicksort
51 : !! algorithm. It uses a temporary array, where it stores the partially
52 : !! ranked indices of the values. It iterates until it can bring the
53 : !! number of values lower than the pivot to exactly NORD, and then uses
54 : !! an insertion sort to rank this set, since it is supposedly small.
55 : !!
56 : !! \code{.f90} subroutine RINPAR (XVALT, IRNGT, NORD) \endcode
57 : !!
58 : !! Ranks partially XVALT by IRNGT,
59 : !! up to order NORD This version is not optimized for performance, and is
60 : !! thus not as difficult to read as some other ones. It uses insertion
61 : !! sort, limiting insertion to the first NORD values. It does not use any
62 : !! work array and is faster when NORD is very small (2-5), but worst case
63 : !! behavior (intially inverse sorted) can easily happen. In many cases,
64 : !! the refined quicksort method is faster.
65 : !!
66 : !! \code{.f90} integer function INDNTH (XVALT, NORD) \endcode
67 : !!
68 : !! Returns the index of the NORDth
69 : !! value of XVALT (in increasing order) This routine uses a pivoting
70 : !! strategy such as the one of finding the median based on the quicksort
71 : !! algorithm, but we skew the pivot choice to try to bring it to NORD as
72 : !! fast as possible. It uses 2 temporary arrays, one where it stores the
73 : !! indices of the values smaller than the pivot, and the other for the
74 : !! indices of values larger than the pivot that we might still need later
75 : !! on. It iterates until it can bring the number of values in ILOWT to
76 : !! exactly NORD, and then takes out the original index of the maximum
77 : !! value in this set.
78 : !!
79 : !! \code{.f90} subroutine INDMED (XVALT, INDM) \endcode
80 : !!
81 : !! Returns the index of the median
82 : !! (((Size(XVALT)+1))/2th value) of XVALT This routine uses the recursive
83 : !! procedure described in Knuth, The Art of Computer Programming, vol. 3,
84 : !! 5.3.3 - This procedure is linear in time, and does not require to be
85 : !! able to interpolate in the set as the one used in INDNTH. It also has
86 : !! better worst case behavior than INDNTH, but is about 10% slower in
87 : !! average for random uniformly distributed values.
88 : !!
89 : !! Note that in Orderpack 1.0, this routine was a Function procedure, and
90 : !! is now changed to a Subroutine.
91 : !!
92 : !! <b> Unique ranking </b>
93 : !!
94 : !! \code{.f90} subroutine UNIRNK (XVALT, IRNGT, NUNI) \endcode
95 : !!
96 : !! Ranks an array, removing
97 : !! duplicate entries (uses merge sort). The routine is similar to pure
98 : !! merge-sort ranking, but on the last pass, it discards indices that
99 : !! correspond to duplicate entries. For performance reasons, the first 2
100 : !! passes are taken out of the standard loop, and use dedicated coding.
101 : !!
102 : !! \code{.f90} subroutine UNIPAR (XVALT, IRNGT, NORD) \endcode
103 : !!
104 : !! Ranks partially XVALT by IRNGT,
105 : !! up to order NORD at most, removing duplicate entries This routine uses
106 : !! a pivoting strategy such as the one of finding the median based on the
107 : !! quicksort algorithm, but we skew the pivot choice to try to bring it
108 : !! to NORD as quickly as possible. It uses 2 temporary arrays, one where
109 : !! it stores the indices of the values smaller than the pivot, and the
110 : !! other for the indices of values larger than the pivot that we might
111 : !! still need later on. It iterates until it can bring the number of
112 : !! values in ILOWT to exactly NORD, and then uses an insertion sort to
113 : !! rank this set, since it is supposedly small. At all times, the NORD
114 : !! first values in ILOWT correspond to distinct values of the input
115 : !! array.
116 : !!
117 : !! \code{.f90} subroutine UNIINV (XVALT, IGOEST) \endcode
118 : !!
119 : !! Inverse ranking of an array, with
120 : !! removal of duplicate entries The routine is similar to pure merge-sort
121 : !! ranking, but on the last pass, it sets indices in IGOEST to the rank
122 : !! of the original value in an ordered set with duplicates removed. For
123 : !! performance reasons, the first 2 passes are taken out of the standard
124 : !! loop, and use dedicated coding.
125 : !!
126 : !! \code{.f90} subroutine MULCNT (XVALT, IMULT) \endcode
127 : !!
128 : !! Gives, for each array value, its
129 : !! multiplicity The number of times that a value appears in the array is
130 : !! computed by using inverse ranking, counting for each rank the number
131 : !! of values that ``collide'' to this rank, and returning this sum to the
132 : !! locations in the original set. Uses subroutine UNIINV.
133 : !!
134 : !! <b> Random permutation: an interesting use of ranking </b>
135 : !!
136 : !! A variation of the following problem was raised on the internet
137 : !! sci.math.num-analysis news group: Given an array, I would like to find
138 : !! a random permutation of this array that I could control with a
139 : !! "nearbyness" parameter so that elements stay close to their initial
140 : !! locations. The "nearbyness" parameter ranges from 0 to 1, with 0
141 : !! such that no element moves from its initial location, and 1 such that
142 : !! the permutation is fully random.
143 : !!
144 : !! \code{.f90} subroutine CTRPER (XVALT, PCLS) \endcode
145 : !!
146 : !! Permute array XVALT randomly, but
147 : !! leaving elements close to their initial locations The routine takes
148 : !! the 1...size(XVALT) index array as real values, takes a combination of
149 : !! these values and of random values as a perturbation of the index
150 : !! array, and sorts the initial set according to the ranks of these
151 : !! perturbated indices. The relative proportion of initial order and
152 : !! random order is 1-PCLS / PCLS, thus when PCLS = 0, there is no change
153 : !! in the order whereas the new order is fully random when PCLS = 1. Uses
154 : !! subroutine MRGRNK.
155 : !!
156 : !! The above solution found another application when I was asked the
157 : !! following question: I am given two arrays, representing parents'
158 : !! incomes and their children's incomes, but I do not know which parents
159 : !! correspond to which children. I know from an independent source the
160 : !! value of the correlation coefficient between the incomes of the
161 : !! parents and of their children. I would like to pair the elements of
162 : !! these arrays so that the given correlation coefficient is attained,
163 : !! i.e. to reconstruct a realistic dataset, though very likely not to be
164 : !! the true one.
165 : !!
166 : !! \code{.f90} program GIVCOR \endcode
167 : !!
168 : !! Given two arrays of equal length of unordered values,
169 : !! find a "matching value" in the second array for each value in the
170 : !! first so that the global correlation coefficient reaches exactly a
171 : !! given target The routine first sorts the two arrays, so as to get the
172 : !! match of maximum possible correlation. It then iterates, applying the
173 : !! random permutation algorithm of controlled disorder ctrper to the
174 : !! second array. When the resulting correlation goes beyond (lower than)
175 : !! the target correlation, one steps back and reduces the disorder
176 : !! parameter of the permutation. When the resulting correlation lies
177 : !! between the current one and the target, one replaces the array with
178 : !! the newly permuted one. When the resulting correlation increases from
179 : !! the current value, one increases the disorder parameter. That way, the
180 : !! target correlation is approached from above, by a controlled increase
181 : !! in randomness. Since full randomness leads to zero correlation, the
182 : !! iterations meet the desired coefficient at some point. It may be noted
183 : !! that there could be some cases when one would get stuck in a sort of
184 : !! local minimum, where local perturbations cannot further reduce the
185 : !! correlation and where global ones lead to overpass the target. It
186 : !! seems easier to restart the program with a different seed when this
187 : !! occurs than to design an avoidance scheme. Also, should a negative
188 : !! correlation be desired, the program should be modified to start with
189 : !! one array in reverse order with respect to the other, i.e. coorelation
190 : !! as close to -1 as possible.
191 : !!
192 : !! <b> Full sorting </b>
193 : !!
194 : !! \code{.f90} subroutine INSSOR (XVALT) \endcode
195 : !!
196 : !! Sorts XVALT into increasing order (Insertion
197 : !! sort) This subroutine uses insertion sort. It does not use any work
198 : !! array and is faster when XVALT is of very small size (< 20), or
199 : !! already almost sorted, but worst case behavior (intially inverse
200 : !! sorted) can easily happen. In most cases, the quicksort or merge sort
201 : !! method is faster.
202 : !!
203 : !! \code{.f90} subroutine REFSOR (XVALT) \endcode
204 : !!
205 : !! Sorts XVALT into increasing order (Quick
206 : !! sort) This version is not optimized for performance, and is thus not
207 : !! as difficult to read as some other ones. This subroutine uses
208 : !! quicksort in a recursive implementation, and insertion sort for the
209 : !! last steps with small subsets. It does not use any work array
210 : !!
211 : !! <b> Partial sorting </b>
212 : !!
213 : !! \code{.f90} subroutine INSPAR (XVALT, NORD) \endcode
214 : !!
215 : !! Sorts partially XVALT, bringing the
216 : !! NORD lowest values at the begining of the array. This subroutine uses
217 : !! insertion sort, limiting insertion to the first NORD values. It does
218 : !! not use any work array and is faster when NORD is very small (2-5),
219 : !! but worst case behavior can happen fairly probably (initially inverse
220 : !! sorted). In many cases, the refined quicksort method is faster.
221 : !!
222 : !! \code{.f90} function FNDNTH (XVALT, NORD) \endcode
223 : !!
224 : !! Finds out and returns the NORDth value
225 : !! in XVALT (ascending order) This subroutine uses insertion sort,
226 : !! limiting insertion to the first NORD values, and even less when one
227 : !! can know that the value that is considered will not be the NORDth. It
228 : !! uses only a work array of size NORD and is faster when NORD is very
229 : !! small (2-5), but worst case behavior can happen fairly probably
230 : !! (initially inverse sorted). In many cases, the refined quicksort
231 : !! method implemented by VALNTH / INDNTH is faster, though much more
232 : !! difficult to read and understand.
233 : !!
234 : !! \code{.f90} function VALNTH (XVALT, NORD) \endcode
235 : !!
236 : !! Finds out and returns the NORDth value
237 : !! in XVALT (ascending order) This subroutine simply calls INDNTH.
238 : !!
239 : !! \code{.f90} function VALMED (XVALT) \endcode
240 : !!
241 : !! Finds out and returns the median(((Size(XVALT)+1))/2th value) of XVALT This routine uses the recursive
242 : !! procedure described in Knuth, The Art of Computer Programming, vol. 3,
243 : !! 5.3.3 - This procedure is linear in time, and does not require to be
244 : !! able to interpolate in the set as the one used in VALNTH/INDNTH. It
245 : !! also has better worst case behavior than VALNTH/INDNTH, and is about
246 : !! 20% faster in average for random uniformly distributed values.
247 : !!
248 : !! \code{.f90} function OMEDIAN (XVALT) \endcode
249 : !!
250 : !! It is a modified version of VALMED that
251 : !! provides the average between the two middle values in the case
252 : !! Size(XVALT) is even.
253 : !!
254 : !! <b> Unique sorting </b>
255 : !!
256 : !! \code{.f90} subroutine UNISTA (XVALT, NUNI) \endcode
257 : !!
258 : !! Removes duplicates from an array This
259 : !! subroutine uses merge sort unique inverse ranking. It leaves in the
260 : !! initial set only those entries that are unique, packing the array, and
261 : !! leaving the order of the retained values unchanged.
262 : !> \authors Michel Olagnon
263 : !> \date 2000-2012
264 : !> \changelog
265 : !! - Matthias Cuntz, Apr 2014
266 : !! - adapted to UFZ library
267 : !! - one module, cleaned all warnings
268 : !! - Juliane Mai, Nov 2014
269 : !! - replaced floating comparison by ne(), eq(), etc. from mo_utils
270 : !! - Matthias Cuntz, Jul 2015
271 : !! - median -> omedian
272 : !> \copyright Copyright 2005-\today, the CHS Developers, Sabine Attinger: All rights reserved.
273 : !! FORCES is released under the LGPLv3+ license \license_note
274 : MODULE mo_orderpack
275 :
276 : USE mo_kind, ONLY : i4, sp, dp
277 : USE mo_utils, ONLY : ne, eq, le
278 :
279 : IMPLICIT NONE
280 :
281 : ! Public routines
282 : public :: sort ! alias for refsor
283 : public :: sort_index ! wrapper for mrgrnk
284 :
285 : public :: ctrper
286 : public :: fndnth
287 : public :: indmed
288 : public :: indnth
289 : public :: inspar
290 : public :: inssor
291 : public :: omedian
292 : public :: mrgref
293 : public :: mrgrnk
294 : public :: mulcnt
295 : public :: rapknr
296 : public :: refpar
297 : public :: refsor
298 : public :: rinpar
299 : public :: rnkpar
300 : public :: uniinv
301 : public :: unipar
302 : public :: unirnk
303 : public :: unista
304 : public :: valmed
305 : public :: valnth
306 :
307 : ! aliases/wrapper
308 :
309 : !> \brief Sorts the input array in ascending order.
310 : !> \param[in,out] "real(sp/dp) :: arr(:)" On input: unsorted 1D-array\n
311 : !! On output: ascendingly sorted input array
312 : interface sort
313 : module procedure d_refsor, r_refsor, i_refsor, c_refsor
314 : end interface sort
315 :
316 : !> \brief Gives the indeces that would sort an array in ascending order.
317 : !> \param[in] "real(sp/dp) :: arr(:)" Unsorted 1D-array
318 : !> \return integer(i4) :: indices(:) — Indices that would sort arr in ascending order
319 : interface sort_index
320 : module procedure sort_index_dp, sort_index_sp, sort_index_i4
321 : end interface sort_index
322 :
323 : !> \brief Random permutation ranking.
324 :
325 : !> \details
326 : !! Permute array XVALT randomly, but
327 : !! leaving elements close to their initial locations The routine takes
328 : !! the 1...size(XVALT) index array as real values, takes a combination of
329 : !! these values and of random values as a perturbation of the index
330 : !! array, and sorts the initial set according to the ranks of these
331 : !! perturbated indices. The relative proportion of initial order and
332 : !! random order is 1-PCLS / PCLS, thus when PCLS = 0, there is no change
333 : !! in the order whereas the new order is fully random when PCLS = 1. Uses
334 : !! subroutine MRGRNK.
335 : !!
336 : !! The above solution found another application when I was asked the
337 : !! following question: I am given two arrays, representing parents'
338 : !! incomes and their children's incomes, but I do not know which parents
339 : !! correspond to which children. I know from an independent source the
340 : !! value of the correlation coefficient between the incomes of the
341 : !! parents and of their children. I would like to pair the elements of
342 : !! these arrays so that the given correlation coefficient is attained,
343 : !! i.e. to reconstruct a realistic dataset, though very likely not to be
344 : !! the true one.
345 :
346 : !> \param[inout] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be randomly permuted.
347 : !> \param[in] "integer(i4)/real(sp,dp) :: PCLS" Nearbyness of permutation.
348 :
349 : interface ctrper
350 : module procedure d_ctrper, r_ctrper, i_ctrper
351 : end interface ctrper
352 :
353 : !> \brief Find N-th value in array from insertion sort
354 :
355 : !> \details
356 : !! Finds out and returns the NORDth value
357 : !! in XVALT (ascending order). This subroutine uses insertion sort,
358 : !! limiting insertion to the first NORD values, and even less when one
359 : !! can know that the value that is considered will not be the NORDth. It
360 : !! uses only a work array of size NORD and is faster when NORD is very
361 : !! small (2-5), but worst case behavior can happen fairly probably
362 : !! (initially inverse sorted). In many cases, the refined quicksort
363 : !! method implemented by VALNTH / INDNTH is faster, though much more
364 : !! difficult to read and understand.
365 :
366 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
367 : !> \param[in] "integer(i4) :: NORD" Number of ranked elements.
368 : !> \retval "integer(i4)/real(sp,dp) :: FNDNTH" Value of NORDth rank.
369 :
370 : interface fndnth
371 : module procedure d_fndnth, r_fndnth, i_fndnth
372 : end interface fndnth
373 :
374 : !> \brief Median index of skewed-pivot with quicksort ranking.
375 :
376 : !> \details
377 : !! Returns the index of the median
378 : !! `(((Size(XVALT)+1))/2th value)` of XVALT This routine uses the recursive
379 : !! procedure described in Knuth, The Art of Computer Programming, vol. 3,
380 : !! 5.3.3 - This procedure is linear in time, and does not require to be
381 : !! able to interpolate in the set as the one used in INDNTH. It also has
382 : !! better worst case behavior than INDNTH, but is about 10% slower in
383 : !! average for random uniformly distributed values.\n
384 : !! Note that in Orderpack 1.0, this routine was a Function procedure, and
385 : !! is now changed to a Subroutine.
386 :
387 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
388 : !> \param[out] "integer(i4) :: INDM" Index of Median.
389 :
390 : interface indmed
391 : module procedure d_indmed, r_indmed, i_indmed
392 : end interface indmed
393 :
394 : !> \brief Nth index of skewed-pivot with quicksort ranking.
395 :
396 : !> \details
397 : !! Returns the index of the NORDth
398 : !! value of XVALT (in increasing order). This routine uses a pivoting
399 : !! strategy such as the one of finding the median based on the quicksort
400 : !! algorithm, but we skew the pivot choice to try to bring it to NORD as
401 : !! fast as possible. It uses 2 temporary arrays, one where it stores the
402 : !! indices of the values smaller than the pivot, and the other for the
403 : !! indices of values larger than the pivot that we might still need later
404 : !! on. It iterates until it can bring the number of values in ILOWT to
405 : !! exactly NORD, and then takes out the original index of the maximum
406 : !! value in this set.
407 :
408 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
409 : !> \param[in] "integer(i4) :: NORD" Number of ranked elements.
410 : !> \retval "integer(i4) :: INDNTH" Index of NORDth rank.
411 :
412 : interface indnth
413 : module procedure d_indnth, r_indnth, i_indnth
414 : end interface indnth
415 :
416 : !> \brief Partial insertion sort ranking,
417 :
418 : !> \details
419 : !! Sorts partially XVALT, bringing the
420 : !! NORD lowest values at the begining of the array. This subroutine uses
421 : !! insertion sort, limiting insertion to the first NORD values. It does
422 : !! not use any work array and is faster when NORD is very small (2-5),
423 : !! but worst case behavior can happen fairly probably (initially inverse
424 : !! sorted). In many cases, the refined quicksort method is faster.
425 :
426 : !> \param[inout] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
427 : !> \param[in] "integer(i4) :: NORD" Number of ranked elements from beginning of array.
428 :
429 : interface inspar
430 : module procedure d_inspar, r_inspar, i_inspar
431 : end interface inspar
432 :
433 : !> \brief Insertion sort ranking
434 :
435 : !> \details
436 : !! Sorts XVALT into increasing order (Insertion
437 : !! sort) This subroutine uses insertion sort. It does not use any work
438 : !! array and is faster when XVALT is of very small size (< 20), or
439 : !! already almost sorted, but worst case behavior (intially inverse
440 : !! sorted) can easily happen. In most cases, the quicksort or merge sort
441 : !! method is faster.
442 :
443 : !> \param[inout] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
444 :
445 : interface inssor
446 : module procedure d_inssor, r_inssor, i_inssor, c_inssor
447 : end interface inssor
448 :
449 : !> \brief Find median value of array (case for even elements)
450 :
451 : !> \details
452 : !! It is a modified version of VALMED that
453 : !! provides the average between the two middle values in the case
454 : !! Size(XVALT) is even.
455 :
456 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
457 : !> \retval "integer(i4)/real(sp,dp) :: OMEDIAN" Value of median.
458 :
459 : interface omedian
460 : module procedure d_median, r_median, i_median
461 : end interface omedian
462 :
463 : !> \brief Merge-sort ranking (unoptimized)
464 :
465 : !> \details
466 : !! Ranks array XVALT into index array
467 : !! IRNGT, using merge-sort. This version is not optimized for performance,
468 : !! and is thus not as difficult to read as the previous one.
469 :
470 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
471 : !> \retval "integer(i4), dimension(:) :: IRNGT" Index of rank.
472 :
473 : interface mrgref
474 : module procedure d_mrgref, r_mrgref, i_mrgref
475 : end interface mrgref
476 :
477 : !> \brief Merge-sort ranking
478 :
479 : !> \details
480 : !! Ranks array XVALT into index array IRNGT, using merge-sort.\n
481 : !! For performance reasons, the first 2 passes are taken out of the
482 : !! standard loop, and use dedicated coding.
483 :
484 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
485 : !> \retval "integer(i4), dimension(:) :: IRNGT" Index of rank.
486 :
487 : interface mrgrnk
488 : module procedure D_mrgrnk, R_mrgrnk, I_mrgrnk, C_mrgrnk
489 : end interface mrgrnk
490 :
491 : !> \brief Multiplicity of array values.
492 :
493 : !> \details
494 : !! Gives, for each array value, its
495 : !! multiplicity. The number of times that a value appears in the array is
496 : !! computed by using inverse ranking, counting for each rank the number
497 : !! of values that ``collide'' to this rank, and returning this sum to the
498 : !! locations in the original set. Uses subroutine UNIINV.
499 :
500 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
501 : !> \param[out] "integer(i4), dimension(:) :: IMULT" Multiplicity of array values.
502 :
503 :
504 : interface mulcnt
505 : module procedure d_mulcnt, r_mulcnt, i_mulcnt
506 : end interface mulcnt
507 :
508 : !> \brief Skewed-pivot with quicksort ranking (reversed).
509 :
510 : !> \details
511 : !! Same as `RNKPAR`, but in
512 : !! decreasing order (RAPKNR = RNKPAR spelt backwards).
513 :
514 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
515 : !> \param[in] "integer(i4) :: NORD" Number of ranked elements.
516 : !> \retval "integer(i4), dimension(:) :: IRNGT" Index of rank.
517 :
518 : interface rapknr
519 : module procedure d_rapknr, r_rapknr, i_rapknr
520 : end interface rapknr
521 :
522 : !> \brief Skewed-pivot with quicksort ranking (unoptimized).
523 :
524 : !> \details
525 : !! Ranks partially XVALT by IRNGT,
526 : !! up to order NORD. This version is not optimized for performance, and is
527 : !! thus not as difficult to read as some other ones. It uses a pivoting
528 : !! strategy such as the one of finding the median based on the quicksort
529 : !! algorithm. It uses a temporary array, where it stores the partially
530 : !! ranked indices of the values. It iterates until it can bring the
531 : !! number of values lower than the pivot to exactly NORD, and then uses
532 : !! an insertion sort to rank this set, since it is supposedly small.
533 :
534 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
535 : !> \param[in] "integer(i4) :: NORD" Number of ranked elements.
536 : !> \retval "integer(i4), dimension(:) :: IRNGT" Index of rank.
537 :
538 : interface refpar
539 : module procedure d_refpar, r_refpar, i_refpar
540 : end interface refpar
541 :
542 : !> \brief Quicksort ranking, with insertion sort at last step (unoptimized)
543 :
544 : !> \details
545 : !! Sorts XVALT into increasing order (Quick
546 : !! sort). This version is not optimized for performance, and is thus not
547 : !! as difficult to read as some other ones. This subroutine uses
548 : !! quicksort in a recursive implementation, and insertion sort for the
549 : !! last steps with small subsets. It does not use any work array
550 :
551 : !> \param[inout] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
552 :
553 : interface refsor
554 : module procedure d_refsor, r_refsor, i_refsor, c_refsor
555 : end interface refsor
556 :
557 : !> \brief Insertion sort ranking (unoptimized).
558 :
559 : !> \details
560 : !! Ranks partially XVALT by IRNGT,
561 : !! up to order NORD This version is not optimized for performance, and is
562 : !! thus not as difficult to read as some other ones. It uses insertion
563 : !! sort, limiting insertion to the first NORD values. It does not use any
564 : !! work array and is faster when NORD is very small (2-5), but worst case
565 : !! behavior (intially inverse sorted) can easily happen. In many cases,
566 : !! refined quicksort method is faster.
567 :
568 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
569 : !> \param[in] "integer(i4) :: NORD" Number of ranked elements.
570 : !> \retval "integer(i4), dimension(:) :: IRNGT" Index of rank.
571 :
572 : interface rinpar
573 : module procedure d_rinpar, r_rinpar, i_rinpar
574 : end interface rinpar
575 :
576 : !> \brief Skewed-pivot with quicksort ranking.
577 :
578 : !> \details
579 : !! Ranks partially XVALT by IRNGT,
580 : !! up to order NORD (refined for speed). This routine uses a pivoting
581 : !! strategy such as the one of finding the median based on the quicksort
582 : !! algorithm, but we skew the pivot choice to try to bring it to NORD as
583 : !! fast as possible. It uses 2 temporary arrays, one where it stores the
584 : !! indices of the values smaller than the pivot, and the other for the
585 : !! indices of values larger than the pivot that we might still need later
586 : !! on. It iterates until it can bring the number of values in ILOWT to
587 : !! exactly NORD, and then uses an insertion sort to rank this set, since
588 : !! it is supposedly small.
589 :
590 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
591 : !> \param[in] "integer(i4) :: NORD" Number of ranked elements.
592 : !> \retval "integer(i4), dimension(:) :: IRNGT" Index of rank.
593 :
594 : interface rnkpar
595 : module procedure d_rnkpar, r_rnkpar, i_rnkpar
596 : end interface rnkpar
597 :
598 : !> \brief Merge-sort ranking, with removal of duplicate entries (reversed).
599 :
600 : !> \details
601 : !! Inverse ranking of an array, with
602 : !! removal of duplicate entries. The routine is similar to pure merge-sort
603 : !! ranking, but on the last pass, it sets indices in IGOEST to the rank
604 : !! of the original value in an ordered set with duplicates removed. For
605 : !! performance reasons, the first 2 passes are taken out of the standard
606 : !! loop, and use dedicated coding.
607 :
608 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
609 : !> \param[out] "integer(i4), dimension(:) :: IGOEST" Index of rank.
610 :
611 : interface uniinv
612 : module procedure d_uniinv, r_uniinv, i_uniinv
613 : end interface uniinv
614 : interface nearless
615 : module procedure D_nearless, R_nearless, I_nearless
616 : end interface nearless
617 :
618 : !> \brief Partial quicksort/insertion sort ranking, with removal of duplicate entries.
619 :
620 : !> \details
621 : !! Ranks partially XVALT by IRNGT,
622 : !! up to order NORD at most, removing duplicate entries. This routine uses
623 : !! a pivoting strategy such as the one of finding the median based on the
624 : !! quicksort algorithm, but we skew the pivot choice to try to bring it
625 : !! to NORD as quickly as possible. It uses 2 temporary arrays, one where
626 : !! it stores the indices of the values smaller than the pivot, and the
627 : !! other for the indices of values larger than the pivot that we might
628 : !! still need later on. It iterates until it can bring the number of
629 : !! values in ILOWT to exactly NORD, and then uses an insertion sort to
630 : !! rank this set, since it is supposedly small. At all times, the NORD
631 : !! first values in ILOWT correspond to distinct values of the input
632 : !! array.
633 :
634 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
635 : !> \param[in] "integer(i4) :: NORD" Rank of quicksort ranking.
636 : !> \param[out] "integer(i4), dimension(:) :: IRNGT" Index of rank.
637 :
638 : interface unipar
639 : module procedure d_unipar, r_unipar, i_unipar
640 : end interface unipar
641 :
642 : !> \brief Merge-sort ranking, with removal of duplicate entries.
643 :
644 : !> \details
645 : !! Ranks an array, removing
646 : !! duplicate entries (uses merge sort). The routine is similar to pure
647 : !! merge-sort ranking, but on the last pass, it discards indices that
648 : !! correspond to duplicate entries. For performance reasons, the first 2
649 : !! passes are taken out of the standard loop, and use dedicated coding.
650 :
651 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
652 : !> \param[out] "integer(i4) :: NUNI" Rank of last number after duplicates removed.
653 : !> \param[out] "integer(i4), dimension(:) :: IRNGT" Index of rank.
654 :
655 : interface unirnk
656 : module procedure D_unirnk, R_unirnk, I_unirnk
657 : end interface unirnk
658 :
659 : !> \brief Merge-sort unique inverse ranking.
660 :
661 : !> \details
662 : !! Removes duplicates from an array This
663 : !! subroutine uses merge sort unique inverse ranking. It leaves in the
664 : !! initial set only those entries that are unique, packing the array, and
665 : !! leaving the order of the retained values unchanged.
666 :
667 : !> \param[inout] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
668 : !> \param[out] "integer(i4) :: NUNI" Rank of last number after duplicates removed.
669 :
670 : interface unista
671 : module procedure d_unista, r_unista, i_unista
672 : end interface unista
673 :
674 : !> \brief Find median value of array
675 :
676 : !> \details
677 : !! Finds out and returns the median(((Size(XVALT)+1))/2th value) of XVALT This routine uses the recursive
678 : !! procedure described in Knuth, The Art of Computer Programming, vol. 3,
679 : !! 5.3.3 - This procedure is linear in time, and does not require to be
680 : !! able to interpolate in the set as the one used in VALNTH/INDNTH. It
681 : !! also has better worst case behavior than VALNTH/INDNTH, and is about
682 : !! 20% faster in average for random uniformly distributed values.
683 :
684 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
685 : !> \retval "integer(i4)/real(sp,dp) :: VALMED" Value of median.
686 :
687 : interface valmed
688 : module procedure d_valmed, r_valmed, i_valmed
689 : end interface valmed
690 :
691 : !> \brief Find N-th value in array from quicksort
692 :
693 : !> \details
694 : !! Finds out and returns the NORDth value
695 : !! in XVALT (ascending order). This subroutine simply calls INDNTH.
696 :
697 : !> \param[in] "integer(i4)/real(sp,dp), dimension(:) :: XVALT" Array to be ranked.
698 : !> \param[in] "integer(i4) :: NORD" Number of ranked elements.
699 : !> \retval "integer(i4)/real(sp,dp) :: VALNTH" Value of NORDth rank.
700 :
701 : interface valnth
702 : module procedure d_valnth, r_valnth, i_valnth
703 : end interface valnth
704 :
705 : private :: R_ctrper, I_ctrper, D_ctrper
706 : private :: R_fndnth, I_fndnth, D_fndnth
707 : private :: R_indmed, I_indmed, D_indmed
708 : private :: R_indnth, I_indnth, D_indnth
709 : private :: R_inspar, I_inspar, D_inspar
710 : private :: R_inssor, I_inssor, D_inssor, C_inssor
711 : private :: R_median, I_median, D_median
712 : private :: R_mrgref, I_mrgref, D_mrgref
713 : private :: R_mrgrnk, I_mrgrnk, D_mrgrnk
714 : private :: R_mulcnt, I_mulcnt, D_mulcnt
715 : private :: R_nearless, I_nearless, D_nearless, nearless
716 : private :: R_rapknr, I_rapknr, D_rapknr
717 : private :: R_refpar, I_refpar, D_refpar
718 : private :: R_refsor, I_refsor, D_refsor, C_refsor
719 : private :: R_rinpar, I_rinpar, D_rinpar
720 : private :: R_rnkpar, I_rnkpar, D_rnkpar
721 : private :: R_subsor, I_subsor, D_subsor, C_subsor
722 : private :: R_uniinv, I_uniinv, D_uniinv
723 : private :: R_unipar, I_unipar, D_unipar
724 : private :: R_unirnk, I_unirnk, D_unirnk
725 : private :: R_unista, I_unista, D_unista
726 : private :: R_valmed, I_valmed, D_valmed
727 : private :: R_valnth, I_valnth, D_valnth
728 : private :: r_med, i_med, d_med
729 :
730 : PRIVATE
731 :
732 : Integer(kind = i4), Allocatable, Dimension(:), Save :: IDONT
733 :
734 : CONTAINS
735 :
736 : ! ------------------------------------------------------------------
737 :
738 9008 : FUNCTION sort_index_dp(arr)
739 :
740 : IMPLICIT NONE
741 :
742 : REAL(dp), DIMENSION(:), INTENT(IN) :: arr
743 : INTEGER(i4), DIMENSION(size(arr)) :: sort_index_dp
744 :
745 4504 : call mrgrnk(arr, sort_index_dp)
746 :
747 4504 : END FUNCTION sort_index_dp
748 :
749 4506 : FUNCTION sort_index_sp(arr)
750 :
751 : IMPLICIT NONE
752 :
753 : REAL(sp), DIMENSION(:), INTENT(IN) :: arr
754 : INTEGER(i4), DIMENSION(size(arr)) :: sort_index_sp
755 :
756 1 : call mrgrnk(arr, sort_index_sp)
757 :
758 1 : END FUNCTION sort_index_sp
759 :
760 1 : FUNCTION sort_index_i4(arr)
761 :
762 : IMPLICIT NONE
763 :
764 : integer(i4), DIMENSION(:), INTENT(IN) :: arr
765 : INTEGER(i4), DIMENSION(size(arr)) :: sort_index_i4
766 :
767 0 : call mrgrnk(arr, sort_index_i4)
768 :
769 0 : END FUNCTION sort_index_i4
770 :
771 :
772 : ! ------------------------------------------------------------------
773 :
774 0 : Subroutine D_ctrper (XDONT, PCLS)
775 : ! Permute array XVALT randomly, but leaving elements close
776 : ! to their initial locations (nearbyness is controled by PCLS).
777 : ! _________________________________________________________________
778 : ! The routine takes the 1...size(XVALT) index array as real
779 : ! values, takes a combination of these values and of random
780 : ! values as a perturbation of the index array, and sorts the
781 : ! initial set according to the ranks of these perturbated indices.
782 : ! The relative proportion of initial order and random order
783 : ! is 1-PCLS / PCLS, thus when PCLS = 0, there is no change in
784 : ! the order whereas the new order is fully random when PCLS = 1.
785 : ! Michel Olagnon - May 2000.
786 : ! _________________________________________________________________
787 : ! __________________________________________________________
788 : real(kind = dp), Dimension (:), Intent (InOut) :: XDONT
789 : Real(kind = dp), Intent (In) :: PCLS
790 : ! __________________________________________________________
791 : !
792 0 : Real(kind = dp), Dimension (Size(XDONT)) :: XINDT
793 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: JWRKT
794 0 : Real(kind = dp) :: PWRK
795 : Integer(kind = i4) :: I
796 0 : Real(kind = dp), Dimension (Size(XDONT)) :: II
797 : !
798 0 : Call Random_number (XINDT(:))
799 0 : PWRK = Min (Max (0.0_dp, PCLS), 1.0_dp)
800 0 : XINDT = Real(Size(XDONT), dp) * XINDT
801 0 : forall(I = 1 : size(XDONT)) II(I) = real(I, dp) ! for gnu compiler to be initialised
802 0 : XINDT = PWRK * XINDT + (1.0_dp - PWRK) * II
803 0 : Call MRGRNK (XINDT, JWRKT)
804 0 : XDONT = XDONT (JWRKT)
805 : !
806 0 : End Subroutine D_ctrper
807 :
808 0 : Subroutine R_ctrper (XDONT, PCLS)
809 : ! Permute array XVALT randomly, but leaving elements close
810 : ! to their initial locations (nearbyness is controled by PCLS).
811 : ! _________________________________________________________________
812 : ! The routine takes the 1...size(XVALT) index array as real
813 : ! values, takes a combination of these values and of random
814 : ! values as a perturbation of the index array, and sorts the
815 : ! initial set according to the ranks of these perturbated indices.
816 : ! The relative proportion of initial order and random order
817 : ! is 1-PCLS / PCLS, thus when PCLS = 0, there is no change in
818 : ! the order whereas the new order is fully random when PCLS = 1.
819 : ! Michel Olagnon - May 2000.
820 : ! _________________________________________________________________
821 : ! _________________________________________________________
822 : Real(kind = sp), Dimension (:), Intent (InOut) :: XDONT
823 : Real(kind = sp), Intent (In) :: PCLS
824 : ! __________________________________________________________
825 : !
826 0 : Real(kind = sp), Dimension (Size(XDONT)) :: XINDT
827 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: JWRKT
828 0 : Real(kind = sp) :: PWRK
829 : Integer(kind = i4) :: I
830 0 : Real(kind = sp), Dimension (Size(XDONT)) :: II
831 : !
832 0 : Call Random_number (XINDT(:))
833 0 : PWRK = Min (Max (0.0, PCLS), 1.0)
834 0 : XINDT = Real(Size(XDONT), sp) * XINDT
835 0 : forall(I = 1 : size(XDONT)) II(I) = real(I, sp) ! for gnu compiler to be initialised
836 0 : XINDT = PWRK * XINDT + (1.0 - PWRK) * II
837 0 : Call MRGRNK (XINDT, JWRKT)
838 0 : XDONT = XDONT (JWRKT)
839 : !
840 0 : End Subroutine R_ctrper
841 :
842 0 : Subroutine I_ctrper (XDONT, PCLS)
843 : ! Permute array XVALT randomly, but leaving elements close
844 : ! to their initial locations (nearbyness is controled by PCLS).
845 : ! _________________________________________________________________
846 : ! The routine takes the 1...size(XVALT) index array as real
847 : ! values, takes a combination of these values and of random
848 : ! values as a perturbation of the index array, and sorts the
849 : ! initial set according to the ranks of these perturbated indices.
850 : ! The relative proportion of initial order and random order
851 : ! is 1-PCLS / PCLS, thus when PCLS = 0, there is no change in
852 : ! the order whereas the new order is fully random when PCLS = 1.
853 : ! Michel Olagnon - May 2000.
854 : ! _________________________________________________________________
855 : ! __________________________________________________________
856 : Integer(kind = i4), Dimension (:), Intent (InOut) :: XDONT
857 : Real(kind = sp), Intent (In) :: PCLS
858 : ! __________________________________________________________
859 : !
860 0 : Real(kind = sp), Dimension (Size(XDONT)) :: XINDT
861 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: JWRKT
862 0 : Real(kind = sp) :: PWRK
863 : Integer(kind = i4) :: I
864 0 : Real(kind = sp), Dimension (Size(XDONT)) :: II
865 : !
866 0 : Call Random_number (XINDT(:))
867 0 : PWRK = Min (Max (0.0, PCLS), 1.0)
868 0 : XINDT = Real(Size(XDONT), sp) * XINDT
869 0 : forall(I = 1 : size(XDONT)) II(I) = real(I, sp) ! for gnu compiler to be initialised
870 0 : XINDT = PWRK * XINDT + (1.0 - PWRK) * II
871 0 : Call MRGRNK(XINDT, JWRKT)
872 0 : XDONT = XDONT(JWRKT)
873 : !
874 0 : End Subroutine I_ctrper
875 :
876 0 : Function D_fndnth (XDONT, NORD) Result (FNDNTH)
877 : ! Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
878 : ! ______________________________________________________________________
879 : ! This subroutine uses insertion sort, limiting insertion
880 : ! to the first NORD values. It is faster when NORD is very small (2-5),
881 : ! and it requires only a workarray of size NORD and type of XDONT,
882 : ! but worst case behavior can happen fairly probably (initially inverse
883 : ! sorted). In many cases, the refined quicksort method is faster.
884 : ! Michel Olagnon - Aug. 2000
885 : ! __________________________________________________________
886 : ! __________________________________________________________
887 : real(Kind = dp), Dimension (:), Intent (In) :: XDONT
888 : real(Kind = dp) :: FNDNTH
889 : Integer(kind = i4), Intent (In) :: NORD
890 : ! __________________________________________________________
891 0 : real(Kind = dp), Dimension (NORD) :: XWRKT
892 0 : real(Kind = dp) :: XWRK, XWRK1
893 : !
894 : !
895 : Integer(kind = i4) :: ICRS, IDCR, ILOW, NDON
896 : !
897 0 : XWRKT (1) = XDONT (1)
898 0 : Do ICRS = 2, NORD
899 0 : XWRK = XDONT (ICRS)
900 0 : Do IDCR = ICRS - 1, 1, - 1
901 0 : If (XWRK >= XWRKT(IDCR)) Exit
902 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
903 : End Do
904 0 : XWRKT (IDCR + 1) = XWRK
905 : End Do
906 : !
907 0 : NDON = SIZE (XDONT)
908 0 : XWRK1 = XWRKT (NORD)
909 0 : ILOW = 2 * NORD - NDON
910 0 : Do ICRS = NORD + 1, NDON
911 0 : If (XDONT(ICRS) < XWRK1) Then
912 0 : XWRK = XDONT (ICRS)
913 0 : Do IDCR = NORD - 1, MAX (1, ILOW), - 1
914 0 : If (XWRK >= XWRKT(IDCR)) Exit
915 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
916 : End Do
917 0 : XWRKT (IDCR + 1) = XWRK
918 0 : XWRK1 = XWRKT(NORD)
919 : End If
920 0 : ILOW = ILOW + 1
921 : End Do
922 0 : FNDNTH = XWRK1
923 :
924 : !
925 0 : End Function D_fndnth
926 :
927 0 : Function R_fndnth (XDONT, NORD) Result (FNDNTH)
928 : ! Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
929 : ! ______________________________________________________________________
930 : ! This subroutine uses insertion sort, limiting insertion
931 : ! to the first NORD values. It is faster when NORD is very small (2-5),
932 : ! and it requires only a workarray of size NORD and type of XDONT,
933 : ! but worst case behavior can happen fairly probably (initially inverse
934 : ! sorted). In many cases, the refined quicksort method is faster.
935 : ! Michel Olagnon - Aug. 2000
936 : ! __________________________________________________________
937 : ! _________________________________________________________
938 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
939 : Real(kind = sp) :: FNDNTH
940 : Integer(kind = i4), Intent (In) :: NORD
941 : ! __________________________________________________________
942 0 : Real(kind = sp), Dimension (NORD) :: XWRKT
943 0 : Real(kind = sp) :: XWRK, XWRK1
944 : !
945 : !
946 : Integer(kind = i4) :: ICRS, IDCR, ILOW, NDON
947 : !
948 0 : XWRKT (1) = XDONT (1)
949 0 : Do ICRS = 2, NORD
950 0 : XWRK = XDONT (ICRS)
951 0 : Do IDCR = ICRS - 1, 1, - 1
952 0 : If (XWRK >= XWRKT(IDCR)) Exit
953 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
954 : End Do
955 0 : XWRKT (IDCR + 1) = XWRK
956 : End Do
957 : !
958 0 : NDON = SIZE (XDONT)
959 0 : XWRK1 = XWRKT (NORD)
960 0 : ILOW = 2 * NORD - NDON
961 0 : Do ICRS = NORD + 1, NDON
962 0 : If (XDONT(ICRS) < XWRK1) Then
963 0 : XWRK = XDONT (ICRS)
964 0 : Do IDCR = NORD - 1, MAX (1, ILOW), - 1
965 0 : If (XWRK >= XWRKT(IDCR)) Exit
966 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
967 : End Do
968 0 : XWRKT (IDCR + 1) = XWRK
969 0 : XWRK1 = XWRKT(NORD)
970 : End If
971 0 : ILOW = ILOW + 1
972 : End Do
973 0 : FNDNTH = XWRK1
974 :
975 : !
976 0 : End Function R_fndnth
977 :
978 0 : Function I_fndnth (XDONT, NORD) Result (FNDNTH)
979 : ! Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
980 : ! ______________________________________________________________________
981 : ! This subroutine uses insertion sort, limiting insertion
982 : ! to the first NORD values. It is faster when NORD is very small (2-5),
983 : ! and it requires only a workarray of size NORD and type of XDONT,
984 : ! but worst case behavior can happen fairly probably (initially inverse
985 : ! sorted). In many cases, the refined quicksort method is faster.
986 : ! Michel Olagnon - Aug. 2000
987 : ! __________________________________________________________
988 : ! __________________________________________________________
989 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
990 : Integer(kind = i4) :: fndnth
991 : Integer(kind = i4), Intent (In) :: NORD
992 : ! __________________________________________________________
993 0 : Integer(kind = i4), Dimension (NORD) :: XWRKT
994 : Integer(kind = i4) :: XWRK, XWRK1
995 : !
996 : !
997 : Integer(kind = i4) :: ICRS, IDCR, ILOW, NDON
998 : !
999 0 : XWRKT (1) = XDONT (1)
1000 0 : Do ICRS = 2, NORD
1001 0 : XWRK = XDONT (ICRS)
1002 0 : Do IDCR = ICRS - 1, 1, - 1
1003 0 : If (XWRK >= XWRKT(IDCR)) Exit
1004 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
1005 : End Do
1006 0 : XWRKT (IDCR + 1) = XWRK
1007 : End Do
1008 : !
1009 0 : NDON = SIZE (XDONT)
1010 0 : XWRK1 = XWRKT (NORD)
1011 0 : ILOW = 2 * NORD - NDON
1012 0 : Do ICRS = NORD + 1, NDON
1013 0 : If (XDONT(ICRS) < XWRK1) Then
1014 0 : XWRK = XDONT (ICRS)
1015 0 : Do IDCR = NORD - 1, MAX (1, ILOW), - 1
1016 0 : If (XWRK >= XWRKT(IDCR)) Exit
1017 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
1018 : End Do
1019 0 : XWRKT (IDCR + 1) = XWRK
1020 0 : XWRK1 = XWRKT(NORD)
1021 : End If
1022 0 : ILOW = ILOW + 1
1023 : End Do
1024 0 : FNDNTH = XWRK1
1025 :
1026 : !
1027 0 : End Function I_fndnth
1028 :
1029 0 : Subroutine D_indmed (XDONT, INDM)
1030 : ! Returns index of median value of XDONT.
1031 : ! __________________________________________________________
1032 : real(kind = dp), Dimension (:), Intent (In) :: XDONT
1033 : Integer(kind = i4), Intent (Out) :: INDM
1034 : ! __________________________________________________________
1035 : Integer(kind = i4) :: IDON
1036 : !
1037 0 : Allocate (IDONT (SIZE(XDONT)))
1038 0 : Do IDON = 1, SIZE(XDONT)
1039 0 : IDONT (IDON) = IDON
1040 : End Do
1041 : !
1042 0 : Call d_med (XDONT, IDONT, INDM)
1043 : !
1044 0 : Deallocate (IDONT)
1045 0 : End Subroutine D_indmed
1046 :
1047 0 : Recursive Subroutine d_med (XDATT, IDATT, ires_med)
1048 : ! Finds the index of the median of XDONT using the recursive procedure
1049 : ! described in Knuth, The Art of Computer Programming,
1050 : ! vol. 3, 5.3.3 - This procedure is linear in time, and
1051 : ! does not require to be able to interpolate in the
1052 : ! set as the one used in INDNTH. It also has better worst
1053 : ! case behavior than INDNTH, but is about 30% slower in
1054 : ! average for random uniformly distributed values.
1055 : ! __________________________________________________________
1056 : real(kind = dp), Dimension (:), Intent (In) :: XDATT
1057 : Integer(kind = i4), Dimension (:), Intent (In) :: IDATT
1058 : Integer(kind = i4), Intent (Out) :: ires_med
1059 : ! __________________________________________________________
1060 : !
1061 : real(kind = dp), Parameter :: XHUGE = HUGE (XDATT)
1062 0 : real(kind = dp) :: XWRK, XWRK1, XMED7, XMAX, XMIN
1063 : !
1064 0 : Integer(kind = i4), Dimension (7 * (((Size (IDATT) + 6) / 7 + 6) / 7)) :: ISTRT, IENDT, IMEDT
1065 0 : Integer(kind = i4), Dimension (7 * ((Size(IDATT) + 6) / 7)) :: IWRKT
1066 : Integer(kind = i4) :: NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
1067 : Integer(kind = i4) :: IDEB, ITMP, IDCR, ICRS, ICRS1, ICRS2, IMAX, IMIN
1068 : Integer(kind = i4) :: IWRK, IWRK1, IMED1, IMED7, NDAT
1069 : !
1070 0 : NDAT = Size (IDATT)
1071 0 : NMED = (NDAT + 1) / 2
1072 0 : IWRKT = IDATT
1073 : !
1074 : ! If the number of values is small, then use insertion sort
1075 : !
1076 0 : If (NDAT < 35) Then
1077 : !
1078 : ! Bring minimum to first location to save test in decreasing loop
1079 : !
1080 0 : IDCR = NDAT
1081 0 : If (XDATT (IWRKT (1)) < XDATT (IWRKT (IDCR))) Then
1082 : IWRK = IWRKT (1)
1083 : Else
1084 0 : IWRK = IWRKT (IDCR)
1085 0 : IWRKT (IDCR) = IWRKT (1)
1086 : end if
1087 0 : XWRK = XDATT (IWRK)
1088 0 : Do ITMP = 1, NDAT - 2
1089 0 : IDCR = IDCR - 1
1090 0 : IWRK1 = IWRKT (IDCR)
1091 0 : XWRK1 = XDATT (IWRK1)
1092 0 : If (XWRK1 < XWRK) Then
1093 0 : IWRKT (IDCR) = IWRK
1094 0 : XWRK = XWRK1
1095 0 : IWRK = IWRK1
1096 : end if
1097 : End Do
1098 0 : IWRKT (1) = IWRK
1099 : !
1100 : ! Sort the first half, until we have NMED sorted values
1101 : !
1102 0 : Do ICRS = 3, NMED
1103 0 : XWRK = XDATT (IWRKT (ICRS))
1104 0 : IWRK = IWRKT (ICRS)
1105 0 : IDCR = ICRS - 1
1106 0 : Do
1107 0 : If (XWRK >= XDATT (IWRKT(IDCR))) Exit
1108 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1109 0 : IDCR = IDCR - 1
1110 : End Do
1111 0 : IWRKT (IDCR + 1) = IWRK
1112 : End Do
1113 : !
1114 : ! Insert any value less than the current median in the first half
1115 : !
1116 0 : XWRK1 = XDATT (IWRKT (NMED))
1117 0 : Do ICRS = NMED + 1, NDAT
1118 0 : XWRK = XDATT (IWRKT (ICRS))
1119 0 : IWRK = IWRKT (ICRS)
1120 0 : If (XWRK < XWRK1) Then
1121 0 : IDCR = NMED - 1
1122 0 : Do
1123 0 : If (XWRK >= XDATT (IWRKT(IDCR))) Exit
1124 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1125 0 : IDCR = IDCR - 1
1126 : End Do
1127 0 : IWRKT (IDCR + 1) = IWRK
1128 0 : XWRK1 = XDATT (IWRKT (NMED))
1129 : End If
1130 : End Do
1131 0 : ires_med = IWRKT (NMED)
1132 0 : Return
1133 : End If
1134 : !
1135 : ! Make sorted subsets of 7 elements
1136 : ! This is done by a variant of insertion sort where a first
1137 : ! pass is used to bring the smallest element to the first position
1138 : ! decreasing disorder at the same time, so that we may remove
1139 : ! remove the loop test in the insertion loop.
1140 : !
1141 0 : IMAX = 1
1142 0 : IMIN = 1
1143 0 : XMAX = XDATT (IWRKT(IMAX))
1144 0 : XMIN = XDATT (IWRKT(IMIN))
1145 0 : DO IDEB = 1, NDAT - 6, 7
1146 0 : IDCR = IDEB + 6
1147 0 : If (XDATT (IWRKT(IDEB)) < XDATT (IWRKT(IDCR))) Then
1148 : IWRK = IWRKT(IDEB)
1149 : Else
1150 0 : IWRK = IWRKT (IDCR)
1151 0 : IWRKT (IDCR) = IWRKT(IDEB)
1152 : end if
1153 0 : XWRK = XDATT (IWRK)
1154 0 : Do ITMP = 1, 5
1155 0 : IDCR = IDCR - 1
1156 0 : IWRK1 = IWRKT (IDCR)
1157 0 : XWRK1 = XDATT (IWRK1)
1158 0 : If (XWRK1 < XWRK) Then
1159 0 : IWRKT (IDCR) = IWRK
1160 0 : IWRK = IWRK1
1161 0 : XWRK = XWRK1
1162 : end if
1163 : End Do
1164 0 : IWRKT (IDEB) = IWRK
1165 0 : If (XWRK < XMIN) Then
1166 0 : IMIN = IWRK
1167 0 : XMIN = XWRK
1168 : End If
1169 0 : Do ICRS = IDEB + 1, IDEB + 5
1170 0 : IWRK = IWRKT (ICRS + 1)
1171 0 : XWRK = XDATT (IWRK)
1172 0 : IDON = IWRKT(ICRS)
1173 0 : If (XWRK < XDATT(IDON)) Then
1174 0 : IWRKT (ICRS + 1) = IDON
1175 0 : IDCR = ICRS
1176 0 : IWRK1 = IWRKT (IDCR - 1)
1177 0 : XWRK1 = XDATT (IWRK1)
1178 0 : Do
1179 0 : If (XWRK >= XWRK1) Exit
1180 0 : IWRKT (IDCR) = IWRK1
1181 0 : IDCR = IDCR - 1
1182 0 : IWRK1 = IWRKT (IDCR - 1)
1183 0 : XWRK1 = XDATT (IWRK1)
1184 : End Do
1185 0 : IWRKT (IDCR) = IWRK
1186 : end if
1187 : End Do
1188 0 : If (XWRK > XMAX) Then
1189 0 : IMAX = IWRK
1190 0 : XMAX = XWRK
1191 : End If
1192 : End Do
1193 : !
1194 : ! Add-up alternatively MAX and MIN values to make the number of data
1195 : ! an exact multiple of 7.
1196 : !
1197 0 : IDEB = 7 * (NDAT / 7)
1198 0 : NTRI = NDAT
1199 0 : If (IDEB < NDAT) Then
1200 : !
1201 0 : Do ICRS = IDEB + 1, NDAT
1202 0 : XWRK1 = XDATT (IWRKT (ICRS))
1203 0 : IF (XWRK1 > XMAX) Then
1204 0 : IMAX = IWRKT (ICRS)
1205 0 : XMAX = XWRK1
1206 : End If
1207 0 : IF (XWRK1 < XMIN) Then
1208 0 : IMIN = IWRKT (ICRS)
1209 0 : XMIN = XWRK1
1210 : End If
1211 : End Do
1212 0 : IWRK1 = IMAX
1213 0 : Do ICRS = NDAT + 1, IDEB + 7
1214 0 : IWRKT (ICRS) = IWRK1
1215 0 : If (IWRK1 == IMAX) Then
1216 : IWRK1 = IMIN
1217 : Else
1218 0 : NMED = NMED + 1
1219 0 : IWRK1 = IMAX
1220 : End If
1221 : End Do
1222 : !
1223 0 : Do ICRS = IDEB + 2, IDEB + 7
1224 0 : IWRK = IWRKT (ICRS)
1225 0 : XWRK = XDATT (IWRK)
1226 0 : Do IDCR = ICRS - 1, IDEB + 1, - 1
1227 0 : If (XWRK >= XDATT (IWRKT(IDCR))) Exit
1228 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1229 : End Do
1230 0 : IWRKT (IDCR + 1) = IWRK
1231 : End Do
1232 : !
1233 : NTRI = IDEB + 7
1234 : End If
1235 : !
1236 : ! Make the set of the indices of median values of each sorted subset
1237 : !
1238 0 : IDON1 = 0
1239 0 : Do IDON = 1, NTRI, 7
1240 0 : IDON1 = IDON1 + 1
1241 0 : IMEDT (IDON1) = IWRKT (IDON + 3)
1242 : End Do
1243 : !
1244 : ! Find XMED7, the median of the medians
1245 : !
1246 0 : Call d_med (XDATT, IMEDT(1 : IDON1), IMED7)
1247 0 : XMED7 = XDATT (IMED7)
1248 : !
1249 : ! Count how many values are not higher than (and how many equal to) XMED7
1250 : ! This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
1251 : ! subsets where the median is lower than the median of medians. For similar
1252 : ! reasons, we also have at least 2N/7 values not lower than XMED7. At the
1253 : ! same time, we find in each subset the index of the last value < XMED7,
1254 : ! and that of the first > XMED7. These indices will be used to restrict the
1255 : ! search for the median as the Kth element in the subset (> or <) where
1256 : ! we know it to be.
1257 : !
1258 0 : IDON1 = 1
1259 0 : NLEQ = 0
1260 0 : NEQU = 0
1261 0 : Do IDON = 1, NTRI, 7
1262 0 : IMED = IDON + 3
1263 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
1264 0 : IMED = IMED - 2
1265 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
1266 : IMED = IMED - 1
1267 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
1268 0 : IMED = IMED + 1
1269 : end if
1270 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
1271 0 : IMED = IMED + 2
1272 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
1273 0 : IMED = IMED - 1
1274 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
1275 0 : IMED = IMED + 1
1276 : end if
1277 : end if
1278 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
1279 0 : NLEQ = NLEQ + IMED - IDON
1280 0 : IENDT (IDON1) = IMED - 1
1281 0 : ISTRT (IDON1) = IMED
1282 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
1283 0 : NLEQ = NLEQ + IMED - IDON + 1
1284 0 : IENDT (IDON1) = IMED
1285 0 : ISTRT (IDON1) = IMED + 1
1286 : Else ! If (XDATT (IWRKT (IMED)) == XMED7)
1287 0 : NLEQ = NLEQ + IMED - IDON + 1
1288 0 : NEQU = NEQU + 1
1289 0 : IENDT (IDON1) = IMED - 1
1290 0 : Do IMED1 = IMED - 1, IDON, -1
1291 0 : If (eq(XDATT (IWRKT (IMED1)), XMED7)) Then
1292 0 : NEQU = NEQU + 1
1293 0 : IENDT (IDON1) = IMED1 - 1
1294 : Else
1295 : Exit
1296 : End If
1297 : End Do
1298 0 : ISTRT (IDON1) = IMED + 1
1299 0 : Do IMED1 = IMED + 1, IDON + 6
1300 0 : If (eq(XDATT (IWRKT (IMED1)), XMED7)) Then
1301 0 : NEQU = NEQU + 1
1302 0 : NLEQ = NLEQ + 1
1303 0 : ISTRT (IDON1) = IMED1 + 1
1304 : Else
1305 : Exit
1306 : End If
1307 : End Do
1308 : end if
1309 0 : IDON1 = IDON1 + 1
1310 : End Do
1311 : !
1312 : ! Carry out a partial insertion sort to find the Kth smallest of the
1313 : ! large values, or the Kth largest of the small values, according to
1314 : ! what is needed.
1315 : !
1316 : !
1317 0 : If (NLEQ - NEQU + 1 <= NMED) Then
1318 0 : If (NLEQ < NMED) Then ! Not enough low values
1319 0 : IWRK1 = IMAX
1320 0 : XWRK1 = XDATT (IWRK1)
1321 0 : NORD = NMED - NLEQ
1322 0 : IDON1 = 0
1323 0 : ICRS1 = 1
1324 0 : ICRS2 = 0
1325 0 : IDCR = 0
1326 0 : Do IDON = 1, NTRI, 7
1327 0 : IDON1 = IDON1 + 1
1328 0 : If (ICRS2 < NORD) Then
1329 0 : Do ICRS = ISTRT (IDON1), IDON + 6
1330 0 : If (XDATT (IWRKT (ICRS)) < XWRK1) Then
1331 0 : IWRK = IWRKT (ICRS)
1332 0 : XWRK = XDATT (IWRK)
1333 0 : Do IDCR = ICRS1 - 1, 1, - 1
1334 0 : If (XWRK >= XDATT (IWRKT (IDCR))) Exit
1335 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1336 : End Do
1337 0 : IWRKT (IDCR + 1) = IWRK
1338 0 : IWRK1 = IWRKT (ICRS1)
1339 0 : XWRK1 = XDATT (IWRK1)
1340 : Else
1341 0 : If (ICRS2 < NORD) Then
1342 0 : IWRKT (ICRS1) = IWRKT (ICRS)
1343 0 : IWRK1 = IWRKT (ICRS1)
1344 0 : XWRK1 = XDATT (IWRK1)
1345 : end if
1346 : End If
1347 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
1348 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
1349 : End Do
1350 : Else
1351 0 : Do ICRS = ISTRT (IDON1), IDON + 6
1352 0 : If (XDATT (IWRKT (ICRS)) >= XWRK1) Exit
1353 0 : IWRK = IWRKT (ICRS)
1354 0 : XWRK = XDATT (IWRK)
1355 0 : Do IDCR = ICRS1 - 1, 1, - 1
1356 0 : If (XWRK >= XDATT (IWRKT (IDCR))) Exit
1357 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1358 : End Do
1359 0 : IWRKT (IDCR + 1) = IWRK
1360 0 : IWRK1 = IWRKT (ICRS1)
1361 0 : XWRK1 = XDATT (IWRK1)
1362 : End Do
1363 : End If
1364 : End Do
1365 0 : ires_med = IWRK1
1366 0 : Return
1367 : Else
1368 0 : ires_med = IMED7
1369 0 : Return
1370 : End If
1371 : Else ! If (NLEQ > NMED)
1372 : ! Not enough high values
1373 0 : XWRK1 = -XHUGE
1374 0 : NORD = NLEQ - NEQU - NMED + 1
1375 0 : IDON1 = 0
1376 0 : ICRS1 = 1
1377 0 : ICRS2 = 0
1378 0 : Do IDON = 1, NTRI, 7
1379 0 : IDON1 = IDON1 + 1
1380 0 : If (ICRS2 < NORD) Then
1381 : !
1382 0 : Do ICRS = IDON, IENDT (IDON1)
1383 0 : If (XDATT(IWRKT (ICRS)) > XWRK1) Then
1384 0 : IWRK = IWRKT (ICRS)
1385 0 : XWRK = XDATT (IWRK)
1386 0 : IDCR = ICRS1 - 1
1387 0 : Do IDCR = ICRS1 - 1, 1, - 1
1388 0 : If (XWRK <= XDATT(IWRKT (IDCR))) Exit
1389 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1390 : End Do
1391 0 : IWRKT (IDCR + 1) = IWRK
1392 0 : IWRK1 = IWRKT(ICRS1)
1393 0 : XWRK1 = XDATT(IWRK1)
1394 : Else
1395 0 : If (ICRS2 < NORD) Then
1396 0 : IWRKT (ICRS1) = IWRKT (ICRS)
1397 0 : IWRK1 = IWRKT(ICRS1)
1398 0 : XWRK1 = XDATT(IWRK1)
1399 : End If
1400 : End If
1401 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
1402 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
1403 : End Do
1404 : Else
1405 0 : Do ICRS = IENDT (IDON1), IDON, -1
1406 0 : If (XDATT(IWRKT (ICRS)) <= XWRK1) Exit
1407 0 : IWRK = IWRKT (ICRS)
1408 0 : XWRK = XDATT (IWRK)
1409 0 : IDCR = ICRS1 - 1
1410 0 : Do IDCR = ICRS1 - 1, 1, - 1
1411 0 : If (XWRK <= XDATT(IWRKT (IDCR))) Exit
1412 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1413 : End Do
1414 0 : IWRKT (IDCR + 1) = IWRK
1415 0 : IWRK1 = IWRKT(ICRS1)
1416 0 : XWRK1 = XDATT(IWRK1)
1417 : End Do
1418 : end if
1419 : End Do
1420 : !
1421 0 : ires_med = IWRK1
1422 0 : Return
1423 : End If
1424 : !
1425 0 : END Subroutine d_med
1426 : !
1427 0 : Subroutine R_indmed (XDONT, INDM)
1428 : ! Returns index of median value of XDONT.
1429 : ! __________________________________________________________
1430 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
1431 : Integer(kind = i4), Intent (Out) :: INDM
1432 : ! __________________________________________________________
1433 : Integer(kind = i4) :: IDON
1434 : !
1435 0 : Allocate (IDONT (SIZE(XDONT)))
1436 0 : Do IDON = 1, SIZE(XDONT)
1437 0 : IDONT (IDON) = IDON
1438 : End Do
1439 : !
1440 0 : Call r_med (XDONT, IDONT, INDM)
1441 : !
1442 0 : Deallocate (IDONT)
1443 0 : End Subroutine R_indmed
1444 :
1445 0 : Recursive Subroutine r_med (XDATT, IDATT, ires_med)
1446 : ! Finds the index of the median of XDONT using the recursive procedure
1447 : ! described in Knuth, The Art of Computer Programming,
1448 : ! vol. 3, 5.3.3 - This procedure is linear in time, and
1449 : ! does not require to be able to interpolate in the
1450 : ! set as the one used in INDNTH. It also has better worst
1451 : ! case behavior than INDNTH, but is about 30% slower in
1452 : ! average for random uniformly distributed values.
1453 : ! __________________________________________________________
1454 : Real(kind = sp), Dimension (:), Intent (In) :: XDATT
1455 : Integer(kind = i4), Dimension (:), Intent (In) :: IDATT
1456 : Integer(kind = i4), Intent (Out) :: ires_med
1457 : ! __________________________________________________________
1458 : !
1459 : Real(kind = sp), Parameter :: XHUGE = HUGE (XDATT)
1460 0 : Real(kind = sp) :: XWRK, XWRK1, XMED7, XMAX, XMIN
1461 : !
1462 0 : Integer(kind = i4), Dimension (7 * (((Size (IDATT) + 6) / 7 + 6) / 7)) :: ISTRT, IENDT, IMEDT
1463 0 : Integer(kind = i4), Dimension (7 * ((Size(IDATT) + 6) / 7)) :: IWRKT
1464 : Integer(kind = i4) :: NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
1465 : Integer(kind = i4) :: IDEB, ITMP, IDCR, ICRS, ICRS1, ICRS2, IMAX, IMIN
1466 : Integer(kind = i4) :: IWRK, IWRK1, IMED1, IMED7, NDAT
1467 : !
1468 0 : NDAT = Size (IDATT)
1469 0 : NMED = (NDAT + 1) / 2
1470 0 : IWRKT = IDATT
1471 : !
1472 : ! If the number of values is small, then use insertion sort
1473 : !
1474 0 : If (NDAT < 35) Then
1475 : !
1476 : ! Bring minimum to first location to save test in decreasing loop
1477 : !
1478 0 : IDCR = NDAT
1479 0 : If (XDATT (IWRKT (1)) < XDATT (IWRKT (IDCR))) Then
1480 : IWRK = IWRKT (1)
1481 : Else
1482 0 : IWRK = IWRKT (IDCR)
1483 0 : IWRKT (IDCR) = IWRKT (1)
1484 : end if
1485 0 : XWRK = XDATT (IWRK)
1486 0 : Do ITMP = 1, NDAT - 2
1487 0 : IDCR = IDCR - 1
1488 0 : IWRK1 = IWRKT (IDCR)
1489 0 : XWRK1 = XDATT (IWRK1)
1490 0 : If (XWRK1 < XWRK) Then
1491 0 : IWRKT (IDCR) = IWRK
1492 0 : XWRK = XWRK1
1493 0 : IWRK = IWRK1
1494 : end if
1495 : End Do
1496 0 : IWRKT (1) = IWRK
1497 : !
1498 : ! Sort the first half, until we have NMED sorted values
1499 : !
1500 0 : Do ICRS = 3, NMED
1501 0 : XWRK = XDATT (IWRKT (ICRS))
1502 0 : IWRK = IWRKT (ICRS)
1503 0 : IDCR = ICRS - 1
1504 0 : Do
1505 0 : If (XWRK >= XDATT (IWRKT(IDCR))) Exit
1506 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1507 0 : IDCR = IDCR - 1
1508 : End Do
1509 0 : IWRKT (IDCR + 1) = IWRK
1510 : End Do
1511 : !
1512 : ! Insert any value less than the current median in the first half
1513 : !
1514 0 : XWRK1 = XDATT (IWRKT (NMED))
1515 0 : Do ICRS = NMED + 1, NDAT
1516 0 : XWRK = XDATT (IWRKT (ICRS))
1517 0 : IWRK = IWRKT (ICRS)
1518 0 : If (XWRK < XWRK1) Then
1519 0 : IDCR = NMED - 1
1520 0 : Do
1521 0 : If (XWRK >= XDATT (IWRKT(IDCR))) Exit
1522 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1523 0 : IDCR = IDCR - 1
1524 : End Do
1525 0 : IWRKT (IDCR + 1) = IWRK
1526 0 : XWRK1 = XDATT (IWRKT (NMED))
1527 : End If
1528 : End Do
1529 0 : ires_med = IWRKT (NMED)
1530 0 : Return
1531 : End If
1532 : !
1533 : ! Make sorted subsets of 7 elements
1534 : ! This is done by a variant of insertion sort where a first
1535 : ! pass is used to bring the smallest element to the first position
1536 : ! decreasing disorder at the same time, so that we may remove
1537 : ! remove the loop test in the insertion loop.
1538 : !
1539 0 : IMAX = 1
1540 0 : IMIN = 1
1541 0 : XMAX = XDATT (IWRKT(IMAX))
1542 0 : XMIN = XDATT (IWRKT(IMIN))
1543 0 : DO IDEB = 1, NDAT - 6, 7
1544 0 : IDCR = IDEB + 6
1545 0 : If (XDATT (IWRKT(IDEB)) < XDATT (IWRKT(IDCR))) Then
1546 : IWRK = IWRKT(IDEB)
1547 : Else
1548 0 : IWRK = IWRKT (IDCR)
1549 0 : IWRKT (IDCR) = IWRKT(IDEB)
1550 : end if
1551 0 : XWRK = XDATT (IWRK)
1552 0 : Do ITMP = 1, 5
1553 0 : IDCR = IDCR - 1
1554 0 : IWRK1 = IWRKT (IDCR)
1555 0 : XWRK1 = XDATT (IWRK1)
1556 0 : If (XWRK1 < XWRK) Then
1557 0 : IWRKT (IDCR) = IWRK
1558 0 : IWRK = IWRK1
1559 0 : XWRK = XWRK1
1560 : end if
1561 : End Do
1562 0 : IWRKT (IDEB) = IWRK
1563 0 : If (XWRK < XMIN) Then
1564 0 : IMIN = IWRK
1565 0 : XMIN = XWRK
1566 : End If
1567 0 : Do ICRS = IDEB + 1, IDEB + 5
1568 0 : IWRK = IWRKT (ICRS + 1)
1569 0 : XWRK = XDATT (IWRK)
1570 0 : IDON = IWRKT(ICRS)
1571 0 : If (XWRK < XDATT(IDON)) Then
1572 0 : IWRKT (ICRS + 1) = IDON
1573 0 : IDCR = ICRS
1574 0 : IWRK1 = IWRKT (IDCR - 1)
1575 0 : XWRK1 = XDATT (IWRK1)
1576 0 : Do
1577 0 : If (XWRK >= XWRK1) Exit
1578 0 : IWRKT (IDCR) = IWRK1
1579 0 : IDCR = IDCR - 1
1580 0 : IWRK1 = IWRKT (IDCR - 1)
1581 0 : XWRK1 = XDATT (IWRK1)
1582 : End Do
1583 0 : IWRKT (IDCR) = IWRK
1584 : end if
1585 : End Do
1586 0 : If (XWRK > XMAX) Then
1587 0 : IMAX = IWRK
1588 0 : XMAX = XWRK
1589 : End If
1590 : End Do
1591 : !
1592 : ! Add-up alternatively MAX and MIN values to make the number of data
1593 : ! an exact multiple of 7.
1594 : !
1595 0 : IDEB = 7 * (NDAT / 7)
1596 0 : NTRI = NDAT
1597 0 : If (IDEB < NDAT) Then
1598 : !
1599 0 : Do ICRS = IDEB + 1, NDAT
1600 0 : XWRK1 = XDATT (IWRKT (ICRS))
1601 0 : IF (XWRK1 > XMAX) Then
1602 0 : IMAX = IWRKT (ICRS)
1603 0 : XMAX = XWRK1
1604 : End If
1605 0 : IF (XWRK1 < XMIN) Then
1606 0 : IMIN = IWRKT (ICRS)
1607 0 : XMIN = XWRK1
1608 : End If
1609 : End Do
1610 0 : IWRK1 = IMAX
1611 0 : Do ICRS = NDAT + 1, IDEB + 7
1612 0 : IWRKT (ICRS) = IWRK1
1613 0 : If (IWRK1 == IMAX) Then
1614 : IWRK1 = IMIN
1615 : Else
1616 0 : NMED = NMED + 1
1617 0 : IWRK1 = IMAX
1618 : End If
1619 : End Do
1620 : !
1621 0 : Do ICRS = IDEB + 2, IDEB + 7
1622 0 : IWRK = IWRKT (ICRS)
1623 0 : XWRK = XDATT (IWRK)
1624 0 : Do IDCR = ICRS - 1, IDEB + 1, - 1
1625 0 : If (XWRK >= XDATT (IWRKT(IDCR))) Exit
1626 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1627 : End Do
1628 0 : IWRKT (IDCR + 1) = IWRK
1629 : End Do
1630 : !
1631 : NTRI = IDEB + 7
1632 : End If
1633 : !
1634 : ! Make the set of the indices of median values of each sorted subset
1635 : !
1636 0 : IDON1 = 0
1637 0 : Do IDON = 1, NTRI, 7
1638 0 : IDON1 = IDON1 + 1
1639 0 : IMEDT (IDON1) = IWRKT (IDON + 3)
1640 : End Do
1641 : !
1642 : ! Find XMED7, the median of the medians
1643 : !
1644 0 : Call r_med (XDATT, IMEDT(1 : IDON1), IMED7)
1645 0 : XMED7 = XDATT (IMED7)
1646 : !
1647 : ! Count how many values are not higher than (and how many equal to) XMED7
1648 : ! This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
1649 : ! subsets where the median is lower than the median of medians. For similar
1650 : ! reasons, we also have at least 2N/7 values not lower than XMED7. At the
1651 : ! same time, we find in each subset the index of the last value < XMED7,
1652 : ! and that of the first > XMED7. These indices will be used to restrict the
1653 : ! search for the median as the Kth element in the subset (> or <) where
1654 : ! we know it to be.
1655 : !
1656 0 : IDON1 = 1
1657 0 : NLEQ = 0
1658 0 : NEQU = 0
1659 0 : Do IDON = 1, NTRI, 7
1660 0 : IMED = IDON + 3
1661 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
1662 0 : IMED = IMED - 2
1663 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
1664 : IMED = IMED - 1
1665 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
1666 0 : IMED = IMED + 1
1667 : end if
1668 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
1669 0 : IMED = IMED + 2
1670 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
1671 0 : IMED = IMED - 1
1672 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
1673 0 : IMED = IMED + 1
1674 : end if
1675 : end if
1676 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
1677 0 : NLEQ = NLEQ + IMED - IDON
1678 0 : IENDT (IDON1) = IMED - 1
1679 0 : ISTRT (IDON1) = IMED
1680 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
1681 0 : NLEQ = NLEQ + IMED - IDON + 1
1682 0 : IENDT (IDON1) = IMED
1683 0 : ISTRT (IDON1) = IMED + 1
1684 : Else ! If (XDATT (IWRKT (IMED)) == XMED7)
1685 0 : NLEQ = NLEQ + IMED - IDON + 1
1686 0 : NEQU = NEQU + 1
1687 0 : IENDT (IDON1) = IMED - 1
1688 0 : Do IMED1 = IMED - 1, IDON, -1
1689 0 : If (eq(XDATT (IWRKT (IMED1)), XMED7)) Then
1690 0 : NEQU = NEQU + 1
1691 0 : IENDT (IDON1) = IMED1 - 1
1692 : Else
1693 : Exit
1694 : End If
1695 : End Do
1696 0 : ISTRT (IDON1) = IMED + 1
1697 0 : Do IMED1 = IMED + 1, IDON + 6
1698 0 : If (eq(XDATT (IWRKT (IMED1)), XMED7)) Then
1699 0 : NEQU = NEQU + 1
1700 0 : NLEQ = NLEQ + 1
1701 0 : ISTRT (IDON1) = IMED1 + 1
1702 : Else
1703 : Exit
1704 : End If
1705 : End Do
1706 : end if
1707 0 : IDON1 = IDON1 + 1
1708 : End Do
1709 : !
1710 : ! Carry out a partial insertion sort to find the Kth smallest of the
1711 : ! large values, or the Kth largest of the small values, according to
1712 : ! what is needed.
1713 : !
1714 : !
1715 0 : If (NLEQ - NEQU + 1 <= NMED) Then
1716 0 : If (NLEQ < NMED) Then ! Not enough low values
1717 0 : IWRK1 = IMAX
1718 0 : XWRK1 = XDATT (IWRK1)
1719 0 : NORD = NMED - NLEQ
1720 0 : IDON1 = 0
1721 0 : ICRS1 = 1
1722 0 : ICRS2 = 0
1723 0 : IDCR = 0
1724 0 : Do IDON = 1, NTRI, 7
1725 0 : IDON1 = IDON1 + 1
1726 0 : If (ICRS2 < NORD) Then
1727 0 : Do ICRS = ISTRT (IDON1), IDON + 6
1728 0 : If (XDATT (IWRKT (ICRS)) < XWRK1) Then
1729 0 : IWRK = IWRKT (ICRS)
1730 0 : XWRK = XDATT (IWRK)
1731 0 : Do IDCR = ICRS1 - 1, 1, - 1
1732 0 : If (XWRK >= XDATT (IWRKT (IDCR))) Exit
1733 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1734 : End Do
1735 0 : IWRKT (IDCR + 1) = IWRK
1736 0 : IWRK1 = IWRKT (ICRS1)
1737 0 : XWRK1 = XDATT (IWRK1)
1738 : Else
1739 0 : If (ICRS2 < NORD) Then
1740 0 : IWRKT (ICRS1) = IWRKT (ICRS)
1741 0 : IWRK1 = IWRKT (ICRS1)
1742 0 : XWRK1 = XDATT (IWRK1)
1743 : end if
1744 : End If
1745 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
1746 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
1747 : End Do
1748 : Else
1749 0 : Do ICRS = ISTRT (IDON1), IDON + 6
1750 0 : If (XDATT (IWRKT (ICRS)) >= XWRK1) Exit
1751 0 : IWRK = IWRKT (ICRS)
1752 0 : XWRK = XDATT (IWRK)
1753 0 : Do IDCR = ICRS1 - 1, 1, - 1
1754 0 : If (XWRK >= XDATT (IWRKT (IDCR))) Exit
1755 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1756 : End Do
1757 0 : IWRKT (IDCR + 1) = IWRK
1758 0 : IWRK1 = IWRKT (ICRS1)
1759 0 : XWRK1 = XDATT (IWRK1)
1760 : End Do
1761 : End If
1762 : End Do
1763 0 : ires_med = IWRK1
1764 0 : Return
1765 : Else
1766 0 : ires_med = IMED7
1767 0 : Return
1768 : End If
1769 : Else ! If (NLEQ > NMED)
1770 : ! Not enough high values
1771 0 : XWRK1 = -XHUGE
1772 0 : NORD = NLEQ - NEQU - NMED + 1
1773 0 : IDON1 = 0
1774 0 : ICRS1 = 1
1775 0 : ICRS2 = 0
1776 0 : Do IDON = 1, NTRI, 7
1777 0 : IDON1 = IDON1 + 1
1778 0 : If (ICRS2 < NORD) Then
1779 : !
1780 0 : Do ICRS = IDON, IENDT (IDON1)
1781 0 : If (XDATT(IWRKT (ICRS)) > XWRK1) Then
1782 0 : IWRK = IWRKT (ICRS)
1783 0 : XWRK = XDATT (IWRK)
1784 0 : IDCR = ICRS1 - 1
1785 0 : Do IDCR = ICRS1 - 1, 1, - 1
1786 0 : If (XWRK <= XDATT(IWRKT (IDCR))) Exit
1787 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1788 : End Do
1789 0 : IWRKT (IDCR + 1) = IWRK
1790 0 : IWRK1 = IWRKT(ICRS1)
1791 0 : XWRK1 = XDATT(IWRK1)
1792 : Else
1793 0 : If (ICRS2 < NORD) Then
1794 0 : IWRKT (ICRS1) = IWRKT (ICRS)
1795 0 : IWRK1 = IWRKT(ICRS1)
1796 0 : XWRK1 = XDATT(IWRK1)
1797 : End If
1798 : End If
1799 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
1800 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
1801 : End Do
1802 : Else
1803 0 : Do ICRS = IENDT (IDON1), IDON, -1
1804 0 : If (XDATT(IWRKT (ICRS)) <= XWRK1) Exit
1805 0 : IWRK = IWRKT (ICRS)
1806 0 : XWRK = XDATT (IWRK)
1807 0 : IDCR = ICRS1 - 1
1808 0 : Do IDCR = ICRS1 - 1, 1, - 1
1809 0 : If (XWRK <= XDATT(IWRKT (IDCR))) Exit
1810 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1811 : End Do
1812 0 : IWRKT (IDCR + 1) = IWRK
1813 0 : IWRK1 = IWRKT(ICRS1)
1814 0 : XWRK1 = XDATT(IWRK1)
1815 : End Do
1816 : end if
1817 : End Do
1818 : !
1819 0 : ires_med = IWRK1
1820 0 : Return
1821 : End If
1822 : !
1823 0 : END Subroutine r_med
1824 :
1825 0 : Subroutine I_indmed (XDONT, INDM)
1826 : ! Returns index of median value of XDONT.
1827 : ! __________________________________________________________
1828 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
1829 : Integer(kind = i4), Intent (Out) :: INDM
1830 : ! __________________________________________________________
1831 : Integer(kind = i4) :: IDON
1832 : !
1833 0 : Allocate (IDONT (SIZE(XDONT)))
1834 0 : Do IDON = 1, SIZE(XDONT)
1835 0 : IDONT (IDON) = IDON
1836 : End Do
1837 : !
1838 0 : Call i_med(XDONT, IDONT, INDM)
1839 : !
1840 0 : Deallocate (IDONT)
1841 0 : End Subroutine I_indmed
1842 :
1843 0 : Recursive Subroutine i_med (XDATT, IDATT, ires_med)
1844 : ! Finds the index of the median of XDONT using the recursive procedure
1845 : ! described in Knuth, The Art of Computer Programming,
1846 : ! vol. 3, 5.3.3 - This procedure is linear in time, and
1847 : ! does not require to be able to interpolate in the
1848 : ! set as the one used in INDNTH. It also has better worst
1849 : ! case behavior than INDNTH, but is about 30% slower in
1850 : ! average for random uniformly distributed values.
1851 : ! __________________________________________________________
1852 : Integer(kind = i4), Dimension (:), Intent (In) :: XDATT
1853 : Integer(kind = i4), Dimension (:), Intent (In) :: IDATT
1854 : Integer(kind = i4), Intent (Out) :: ires_med
1855 : ! __________________________________________________________
1856 : !
1857 : Integer(kind = i4), Parameter :: XHUGE = HUGE (XDATT)
1858 : Integer(kind = i4) :: XWRK, XWRK1, XMED7, XMAX, XMIN
1859 : !
1860 0 : Integer(kind = i4), Dimension (7 * (((Size (IDATT) + 6) / 7 + 6) / 7)) :: ISTRT, IENDT, IMEDT
1861 0 : Integer(kind = i4), Dimension (7 * ((Size(IDATT) + 6) / 7)) :: IWRKT
1862 : Integer(kind = i4) :: NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
1863 : Integer(kind = i4) :: IDEB, ITMP, IDCR, ICRS, ICRS1, ICRS2, IMAX, IMIN
1864 : Integer(kind = i4) :: IWRK, IWRK1, IMED1, IMED7, NDAT
1865 : !
1866 0 : NDAT = Size (IDATT)
1867 0 : NMED = (NDAT + 1) / 2
1868 0 : IWRKT = IDATT
1869 : !
1870 : ! If the number of values is small, then use insertion sort
1871 : !
1872 0 : If (NDAT < 35) Then
1873 : !
1874 : ! Bring minimum to first location to save test in decreasing loop
1875 : !
1876 0 : IDCR = NDAT
1877 0 : If (XDATT (IWRKT (1)) < XDATT (IWRKT (IDCR))) Then
1878 : IWRK = IWRKT (1)
1879 : Else
1880 0 : IWRK = IWRKT (IDCR)
1881 0 : IWRKT (IDCR) = IWRKT (1)
1882 : end if
1883 0 : XWRK = XDATT (IWRK)
1884 0 : Do ITMP = 1, NDAT - 2
1885 0 : IDCR = IDCR - 1
1886 0 : IWRK1 = IWRKT (IDCR)
1887 0 : XWRK1 = XDATT (IWRK1)
1888 0 : If (XWRK1 < XWRK) Then
1889 0 : IWRKT (IDCR) = IWRK
1890 0 : XWRK = XWRK1
1891 0 : IWRK = IWRK1
1892 : end if
1893 : End Do
1894 0 : IWRKT (1) = IWRK
1895 : !
1896 : ! Sort the first half, until we have NMED sorted values
1897 : !
1898 0 : Do ICRS = 3, NMED
1899 0 : XWRK = XDATT (IWRKT (ICRS))
1900 0 : IWRK = IWRKT (ICRS)
1901 0 : IDCR = ICRS - 1
1902 0 : Do
1903 0 : If (XWRK >= XDATT (IWRKT(IDCR))) Exit
1904 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1905 0 : IDCR = IDCR - 1
1906 : End Do
1907 0 : IWRKT (IDCR + 1) = IWRK
1908 : End Do
1909 : !
1910 : ! Insert any value less than the current median in the first half
1911 : !
1912 0 : XWRK1 = XDATT (IWRKT (NMED))
1913 0 : Do ICRS = NMED + 1, NDAT
1914 0 : XWRK = XDATT (IWRKT (ICRS))
1915 0 : IWRK = IWRKT (ICRS)
1916 0 : If (XWRK < XWRK1) Then
1917 0 : IDCR = NMED - 1
1918 0 : Do
1919 0 : If (XWRK >= XDATT (IWRKT(IDCR))) Exit
1920 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
1921 0 : IDCR = IDCR - 1
1922 : End Do
1923 0 : IWRKT (IDCR + 1) = IWRK
1924 0 : XWRK1 = XDATT (IWRKT (NMED))
1925 : End If
1926 : End Do
1927 0 : ires_med = IWRKT (NMED)
1928 0 : Return
1929 : End If
1930 : !
1931 : ! Make sorted subsets of 7 elements
1932 : ! This is done by a variant of insertion sort where a first
1933 : ! pass is used to bring the smallest element to the first position
1934 : ! decreasing disorder at the same time, so that we may remove
1935 : ! remove the loop test in the insertion loop.
1936 : !
1937 0 : IMAX = 1
1938 0 : IMIN = 1
1939 0 : XMAX = XDATT (IWRKT(IMAX))
1940 0 : XMIN = XDATT (IWRKT(IMIN))
1941 0 : DO IDEB = 1, NDAT - 6, 7
1942 0 : IDCR = IDEB + 6
1943 0 : If (XDATT (IWRKT(IDEB)) < XDATT (IWRKT(IDCR))) Then
1944 : IWRK = IWRKT(IDEB)
1945 : Else
1946 0 : IWRK = IWRKT (IDCR)
1947 0 : IWRKT (IDCR) = IWRKT(IDEB)
1948 : end if
1949 0 : XWRK = XDATT (IWRK)
1950 0 : Do ITMP = 1, 5
1951 0 : IDCR = IDCR - 1
1952 0 : IWRK1 = IWRKT (IDCR)
1953 0 : XWRK1 = XDATT (IWRK1)
1954 0 : If (XWRK1 < XWRK) Then
1955 0 : IWRKT (IDCR) = IWRK
1956 0 : IWRK = IWRK1
1957 0 : XWRK = XWRK1
1958 : end if
1959 : End Do
1960 0 : IWRKT (IDEB) = IWRK
1961 0 : If (XWRK < XMIN) Then
1962 0 : IMIN = IWRK
1963 0 : XMIN = XWRK
1964 : End If
1965 0 : Do ICRS = IDEB + 1, IDEB + 5
1966 0 : IWRK = IWRKT (ICRS + 1)
1967 0 : XWRK = XDATT (IWRK)
1968 0 : IDON = IWRKT(ICRS)
1969 0 : If (XWRK < XDATT(IDON)) Then
1970 0 : IWRKT (ICRS + 1) = IDON
1971 0 : IDCR = ICRS
1972 0 : IWRK1 = IWRKT (IDCR - 1)
1973 0 : XWRK1 = XDATT (IWRK1)
1974 0 : Do
1975 0 : If (XWRK >= XWRK1) Exit
1976 0 : IWRKT (IDCR) = IWRK1
1977 0 : IDCR = IDCR - 1
1978 0 : IWRK1 = IWRKT (IDCR - 1)
1979 0 : XWRK1 = XDATT (IWRK1)
1980 : End Do
1981 0 : IWRKT (IDCR) = IWRK
1982 : end if
1983 : End Do
1984 0 : If (XWRK > XMAX) Then
1985 0 : IMAX = IWRK
1986 0 : XMAX = XWRK
1987 : End If
1988 : End Do
1989 : !
1990 : ! Add-up alternatively MAX and MIN values to make the number of data
1991 : ! an exact multiple of 7.
1992 : !
1993 0 : IDEB = 7 * (NDAT / 7)
1994 0 : NTRI = NDAT
1995 0 : If (IDEB < NDAT) Then
1996 : !
1997 0 : Do ICRS = IDEB + 1, NDAT
1998 0 : XWRK1 = XDATT (IWRKT (ICRS))
1999 0 : IF (XWRK1 > XMAX) Then
2000 0 : IMAX = IWRKT (ICRS)
2001 0 : XMAX = XWRK1
2002 : End If
2003 0 : IF (XWRK1 < XMIN) Then
2004 0 : IMIN = IWRKT (ICRS)
2005 0 : XMIN = XWRK1
2006 : End If
2007 : End Do
2008 0 : IWRK1 = IMAX
2009 0 : Do ICRS = NDAT + 1, IDEB + 7
2010 0 : IWRKT (ICRS) = IWRK1
2011 0 : If (IWRK1 == IMAX) Then
2012 : IWRK1 = IMIN
2013 : Else
2014 0 : NMED = NMED + 1
2015 0 : IWRK1 = IMAX
2016 : End If
2017 : End Do
2018 : !
2019 0 : Do ICRS = IDEB + 2, IDEB + 7
2020 0 : IWRK = IWRKT (ICRS)
2021 0 : XWRK = XDATT (IWRK)
2022 0 : Do IDCR = ICRS - 1, IDEB + 1, - 1
2023 0 : If (XWRK >= XDATT (IWRKT(IDCR))) Exit
2024 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
2025 : End Do
2026 0 : IWRKT (IDCR + 1) = IWRK
2027 : End Do
2028 : !
2029 : NTRI = IDEB + 7
2030 : End If
2031 : !
2032 : ! Make the set of the indices of median values of each sorted subset
2033 : !
2034 0 : IDON1 = 0
2035 0 : Do IDON = 1, NTRI, 7
2036 0 : IDON1 = IDON1 + 1
2037 0 : IMEDT (IDON1) = IWRKT (IDON + 3)
2038 : End Do
2039 : !
2040 : ! Find XMED7, the median of the medians
2041 : !
2042 0 : Call i_med (XDATT, IMEDT(1 : IDON1), IMED7)
2043 0 : XMED7 = XDATT (IMED7)
2044 : !
2045 : ! Count how many values are not higher than (and how many equal to) XMED7
2046 : ! This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
2047 : ! subsets where the median is lower than the median of medians. For similar
2048 : ! reasons, we also have at least 2N/7 values not lower than XMED7. At the
2049 : ! same time, we find in each subset the index of the last value < XMED7,
2050 : ! and that of the first > XMED7. These indices will be used to restrict the
2051 : ! search for the median as the Kth element in the subset (> or <) where
2052 : ! we know it to be.
2053 : !
2054 0 : IDON1 = 1
2055 0 : NLEQ = 0
2056 0 : NEQU = 0
2057 0 : Do IDON = 1, NTRI, 7
2058 0 : IMED = IDON + 3
2059 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
2060 0 : IMED = IMED - 2
2061 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
2062 : IMED = IMED - 1
2063 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
2064 0 : IMED = IMED + 1
2065 : end if
2066 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
2067 0 : IMED = IMED + 2
2068 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
2069 0 : IMED = IMED - 1
2070 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
2071 0 : IMED = IMED + 1
2072 : end if
2073 : end if
2074 0 : If (XDATT (IWRKT (IMED)) > XMED7) Then
2075 0 : NLEQ = NLEQ + IMED - IDON
2076 0 : IENDT (IDON1) = IMED - 1
2077 0 : ISTRT (IDON1) = IMED
2078 0 : Else If (XDATT (IWRKT (IMED)) < XMED7) Then
2079 0 : NLEQ = NLEQ + IMED - IDON + 1
2080 0 : IENDT (IDON1) = IMED
2081 0 : ISTRT (IDON1) = IMED + 1
2082 : Else ! If (XDATT (IWRKT (IMED)) == XMED7)
2083 0 : NLEQ = NLEQ + IMED - IDON + 1
2084 0 : NEQU = NEQU + 1
2085 0 : IENDT (IDON1) = IMED - 1
2086 0 : Do IMED1 = IMED - 1, IDON, -1
2087 0 : If (XDATT (IWRKT (IMED1)) == XMED7) Then
2088 0 : NEQU = NEQU + 1
2089 0 : IENDT (IDON1) = IMED1 - 1
2090 : Else
2091 : Exit
2092 : End If
2093 : End Do
2094 0 : ISTRT (IDON1) = IMED + 1
2095 0 : Do IMED1 = IMED + 1, IDON + 6
2096 0 : If (XDATT (IWRKT (IMED1)) == XMED7) Then
2097 0 : NEQU = NEQU + 1
2098 0 : NLEQ = NLEQ + 1
2099 0 : ISTRT (IDON1) = IMED1 + 1
2100 : Else
2101 : Exit
2102 : End If
2103 : End Do
2104 : end if
2105 0 : IDON1 = IDON1 + 1
2106 : End Do
2107 : !
2108 : ! Carry out a partial insertion sort to find the Kth smallest of the
2109 : ! large values, or the Kth largest of the small values, according to
2110 : ! what is needed.
2111 : !
2112 : !
2113 0 : If (NLEQ - NEQU + 1 <= NMED) Then
2114 0 : If (NLEQ < NMED) Then ! Not enough low values
2115 0 : IWRK1 = IMAX
2116 0 : XWRK1 = XDATT (IWRK1)
2117 0 : NORD = NMED - NLEQ
2118 0 : IDON1 = 0
2119 0 : ICRS1 = 1
2120 0 : ICRS2 = 0
2121 0 : IDCR = 0
2122 0 : Do IDON = 1, NTRI, 7
2123 0 : IDON1 = IDON1 + 1
2124 0 : If (ICRS2 < NORD) Then
2125 0 : Do ICRS = ISTRT (IDON1), IDON + 6
2126 0 : If (XDATT (IWRKT (ICRS)) < XWRK1) Then
2127 0 : IWRK = IWRKT (ICRS)
2128 0 : XWRK = XDATT (IWRK)
2129 0 : Do IDCR = ICRS1 - 1, 1, - 1
2130 0 : If (XWRK >= XDATT (IWRKT (IDCR))) Exit
2131 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
2132 : End Do
2133 0 : IWRKT (IDCR + 1) = IWRK
2134 0 : IWRK1 = IWRKT (ICRS1)
2135 0 : XWRK1 = XDATT (IWRK1)
2136 : Else
2137 0 : If (ICRS2 < NORD) Then
2138 0 : IWRKT (ICRS1) = IWRKT (ICRS)
2139 0 : IWRK1 = IWRKT (ICRS1)
2140 0 : XWRK1 = XDATT (IWRK1)
2141 : end if
2142 : End If
2143 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
2144 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
2145 : End Do
2146 : Else
2147 0 : Do ICRS = ISTRT (IDON1), IDON + 6
2148 0 : If (XDATT (IWRKT (ICRS)) >= XWRK1) Exit
2149 0 : IWRK = IWRKT (ICRS)
2150 0 : XWRK = XDATT (IWRK)
2151 0 : Do IDCR = ICRS1 - 1, 1, - 1
2152 0 : If (XWRK >= XDATT (IWRKT (IDCR))) Exit
2153 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
2154 : End Do
2155 0 : IWRKT (IDCR + 1) = IWRK
2156 0 : IWRK1 = IWRKT (ICRS1)
2157 0 : XWRK1 = XDATT (IWRK1)
2158 : End Do
2159 : End If
2160 : End Do
2161 0 : ires_med = IWRK1
2162 0 : Return
2163 : Else
2164 0 : ires_med = IMED7
2165 0 : Return
2166 : End If
2167 : Else ! If (NLEQ > NMED)
2168 : ! Not enough high values
2169 0 : XWRK1 = -XHUGE
2170 0 : NORD = NLEQ - NEQU - NMED + 1
2171 0 : IDON1 = 0
2172 0 : ICRS1 = 1
2173 0 : ICRS2 = 0
2174 0 : Do IDON = 1, NTRI, 7
2175 0 : IDON1 = IDON1 + 1
2176 0 : If (ICRS2 < NORD) Then
2177 : !
2178 0 : Do ICRS = IDON, IENDT (IDON1)
2179 0 : If (XDATT(IWRKT (ICRS)) > XWRK1) Then
2180 0 : IWRK = IWRKT (ICRS)
2181 0 : XWRK = XDATT (IWRK)
2182 0 : IDCR = ICRS1 - 1
2183 0 : Do IDCR = ICRS1 - 1, 1, - 1
2184 0 : If (XWRK <= XDATT(IWRKT (IDCR))) Exit
2185 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
2186 : End Do
2187 0 : IWRKT (IDCR + 1) = IWRK
2188 0 : IWRK1 = IWRKT(ICRS1)
2189 0 : XWRK1 = XDATT(IWRK1)
2190 : Else
2191 0 : If (ICRS2 < NORD) Then
2192 0 : IWRKT (ICRS1) = IWRKT (ICRS)
2193 0 : IWRK1 = IWRKT(ICRS1)
2194 0 : XWRK1 = XDATT(IWRK1)
2195 : End If
2196 : End If
2197 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
2198 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
2199 : End Do
2200 : Else
2201 0 : Do ICRS = IENDT (IDON1), IDON, -1
2202 0 : If (XDATT(IWRKT (ICRS)) <= XWRK1) Exit
2203 0 : IWRK = IWRKT (ICRS)
2204 0 : XWRK = XDATT (IWRK)
2205 0 : IDCR = ICRS1 - 1
2206 0 : Do IDCR = ICRS1 - 1, 1, - 1
2207 0 : If (XWRK <= XDATT(IWRKT (IDCR))) Exit
2208 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
2209 : End Do
2210 0 : IWRKT (IDCR + 1) = IWRK
2211 0 : IWRK1 = IWRKT(ICRS1)
2212 0 : XWRK1 = XDATT(IWRK1)
2213 : End Do
2214 : end if
2215 : End Do
2216 : !
2217 0 : ires_med = IWRK1
2218 0 : Return
2219 : End If
2220 : !
2221 0 : END Subroutine i_med
2222 :
2223 0 : Function D_indnth (XDONT, NORD) Result (INDNTH)
2224 : ! Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
2225 : ! __________________________________________________________
2226 : ! This routine uses a pivoting strategy such as the one of
2227 : ! finding the median based on the quicksort algorithm, but
2228 : ! we skew the pivot choice to try to bring it to NORD as
2229 : ! fast as possible. It uses 2 temporary arrays, where it
2230 : ! stores the indices of the values smaller than the pivot
2231 : ! (ILOWT), and the indices of values larger than the pivot
2232 : ! that we might still need later on (IHIGT). It iterates
2233 : ! until it can bring the number of values in ILOWT to
2234 : ! exactly NORD, and then finds the maximum of this set.
2235 : ! Michel Olagnon - Aug. 2000
2236 : ! __________________________________________________________
2237 : ! __________________________________________________________
2238 : real(kind = dp), Dimension (:), Intent (In) :: XDONT
2239 : Integer(kind = i4) :: INDNTH
2240 : Integer(kind = i4), Intent (In) :: NORD
2241 : ! __________________________________________________________
2242 0 : real(kind = dp) :: XPIV, XWRK, XWRK1, XMIN, XMAX
2243 : !
2244 0 : Integer(kind = i4), Dimension (NORD) :: IRNGT
2245 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
2246 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
2247 : Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
2248 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
2249 : !
2250 0 : NDON = SIZE (XDONT)
2251 0 : INTH = NORD
2252 : !
2253 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
2254 : !
2255 0 : If (NDON < 2) Then
2256 : If (INTH == 1) INDNTH = 1
2257 : Return
2258 : End If
2259 : !
2260 : ! One chooses a pivot, best estimate possible to put fractile near
2261 : ! mid-point of the set of low values.
2262 : !
2263 0 : If (XDONT(2) < XDONT(1)) Then
2264 0 : ILOWT (1) = 2
2265 0 : IHIGT (1) = 1
2266 : Else
2267 0 : ILOWT (1) = 1
2268 0 : IHIGT (1) = 2
2269 : End If
2270 : !
2271 0 : If (NDON < 3) Then
2272 0 : If (INTH == 1) INDNTH = ILOWT (1)
2273 0 : If (INTH == 2) INDNTH = IHIGT (1)
2274 0 : Return
2275 : End If
2276 : !
2277 0 : If (XDONT(3) < XDONT(IHIGT(1))) Then
2278 0 : IHIGT (2) = IHIGT (1)
2279 0 : If (XDONT(3) < XDONT(ILOWT(1))) Then
2280 0 : IHIGT (1) = ILOWT (1)
2281 0 : ILOWT (1) = 3
2282 : Else
2283 0 : IHIGT (1) = 3
2284 : End If
2285 : Else
2286 0 : IHIGT (2) = 3
2287 : End If
2288 : !
2289 0 : If (NDON < 4) Then
2290 0 : If (INTH == 1) INDNTH = ILOWT (1)
2291 0 : If (INTH == 2) INDNTH = IHIGT (1)
2292 0 : If (INTH == 3) INDNTH = IHIGT (2)
2293 0 : Return
2294 : End If
2295 : !
2296 0 : If (XDONT(NDON) < XDONT(IHIGT(1))) Then
2297 0 : IHIGT (3) = IHIGT (2)
2298 0 : IHIGT (2) = IHIGT (1)
2299 0 : If (XDONT(NDON) < XDONT(ILOWT(1))) Then
2300 0 : IHIGT (1) = ILOWT (1)
2301 0 : ILOWT (1) = NDON
2302 : Else
2303 0 : IHIGT (1) = NDON
2304 : End If
2305 : Else
2306 0 : IHIGT (3) = NDON
2307 : End If
2308 : !
2309 0 : If (NDON < 5) Then
2310 0 : If (INTH == 1) INDNTH = ILOWT (1)
2311 0 : If (INTH == 2) INDNTH = IHIGT (1)
2312 0 : If (INTH == 3) INDNTH = IHIGT (2)
2313 0 : If (INTH == 4) INDNTH = IHIGT (3)
2314 0 : Return
2315 : End If
2316 : !
2317 :
2318 0 : JLOW = 1
2319 0 : JHIG = 3
2320 0 : XPIV = XDONT (ILOWT(1)) + REAL(2 * INTH, dp) / REAL(NDON + INTH, dp) * &
2321 0 : (XDONT(IHIGT(3)) - XDONT(ILOWT(1)))
2322 0 : If (XPIV >= XDONT(IHIGT(1))) Then
2323 : XPIV = XDONT (ILOWT(1)) + REAL(2 * INTH, dp) / REAL(NDON + INTH, dp) * &
2324 0 : (XDONT(IHIGT(2)) - XDONT(ILOWT(1)))
2325 0 : If (XPIV >= XDONT(IHIGT(1))) &
2326 : XPIV = XDONT (ILOWT(1)) + REAL(2 * INTH, dp) / REAL(NDON + INTH, dp) * &
2327 0 : (XDONT(IHIGT(1)) - XDONT(ILOWT(1)))
2328 : End If
2329 : !
2330 : ! One puts values > pivot in the end and those <= pivot
2331 : ! at the beginning. This is split in 2 cases, so that
2332 : ! we can skip the loop test a number of times.
2333 : ! As we are also filling in the work arrays at the same time
2334 : ! we stop filling in the IHIGT array as soon as we have more
2335 : ! than enough values in ILOWT.
2336 : !
2337 : !
2338 0 : If (XDONT(NDON) > XPIV) Then
2339 : ICRS = 3
2340 : Do
2341 0 : ICRS = ICRS + 1
2342 0 : If (XDONT(ICRS) > XPIV) Then
2343 0 : If (ICRS >= NDON) Exit
2344 0 : JHIG = JHIG + 1
2345 0 : IHIGT (JHIG) = ICRS
2346 : Else
2347 0 : JLOW = JLOW + 1
2348 0 : ILOWT (JLOW) = ICRS
2349 0 : If (JLOW >= INTH) Exit
2350 : End If
2351 : End Do
2352 : !
2353 : ! One restricts further processing because it is no use
2354 : ! to store more high values
2355 : !
2356 0 : If (ICRS < NDON - 1) Then
2357 : Do
2358 0 : ICRS = ICRS + 1
2359 0 : If (XDONT(ICRS) <= XPIV) Then
2360 0 : JLOW = JLOW + 1
2361 0 : ILOWT (JLOW) = ICRS
2362 0 : Else If (ICRS >= NDON) Then
2363 : Exit
2364 : End If
2365 : End Do
2366 : End If
2367 : !
2368 : !
2369 : Else
2370 : !
2371 : ! Same as above, but this is not as easy to optimize, so the
2372 : ! DO-loop is kept
2373 : !
2374 0 : Do ICRS = 4, NDON - 1
2375 0 : If (XDONT(ICRS) > XPIV) Then
2376 0 : JHIG = JHIG + 1
2377 0 : IHIGT (JHIG) = ICRS
2378 : Else
2379 0 : JLOW = JLOW + 1
2380 0 : ILOWT (JLOW) = ICRS
2381 0 : If (JLOW >= INTH) Exit
2382 : End If
2383 : End Do
2384 : !
2385 0 : If (ICRS < NDON - 1) Then
2386 : Do
2387 0 : ICRS = ICRS + 1
2388 0 : If (XDONT(ICRS) <= XPIV) Then
2389 0 : If (ICRS >= NDON) Exit
2390 0 : JLOW = JLOW + 1
2391 0 : ILOWT (JLOW) = ICRS
2392 : End If
2393 : End Do
2394 : End If
2395 : End If
2396 : !
2397 : JLM2 = 0
2398 : JLM1 = 0
2399 : JHM2 = 0
2400 : JHM1 = 0
2401 : Do
2402 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
2403 : !
2404 : ! We are oscillating. Perturbate by bringing JLOW closer by one
2405 : ! to INTH
2406 : !
2407 0 : If (INTH > JLOW) Then
2408 0 : XMIN = XDONT (IHIGT(1))
2409 0 : IHIG = 1
2410 0 : Do ICRS = 2, JHIG
2411 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
2412 0 : XMIN = XDONT (IHIGT(ICRS))
2413 0 : IHIG = ICRS
2414 : End If
2415 : End Do
2416 : !
2417 0 : JLOW = JLOW + 1
2418 0 : ILOWT (JLOW) = IHIGT (IHIG)
2419 0 : IHIGT (IHIG) = IHIGT (JHIG)
2420 0 : JHIG = JHIG - 1
2421 : Else
2422 :
2423 0 : ILOW = ILOWT (1)
2424 0 : XMAX = XDONT (ILOW)
2425 0 : Do ICRS = 2, JLOW
2426 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
2427 0 : IWRK = ILOWT (ICRS)
2428 0 : XMAX = XDONT (IWRK)
2429 0 : ILOWT (ICRS) = ILOW
2430 0 : ILOW = IWRK
2431 : End If
2432 : End Do
2433 0 : JLOW = JLOW - 1
2434 : End If
2435 : End If
2436 0 : JLM2 = JLM1
2437 0 : JLM1 = JLOW
2438 0 : JHM2 = JHM1
2439 0 : JHM1 = JHIG
2440 : !
2441 : ! We try to bring the number of values in the low values set
2442 : ! closer to INTH.
2443 : !
2444 0 : Select Case (INTH - JLOW)
2445 : Case (2 :)
2446 : !
2447 : ! Not enough values in low part, at least 2 are missing
2448 : !
2449 0 : INTH = INTH - JLOW
2450 0 : JLOW = 0
2451 : Select Case (JHIG)
2452 : !!!!! CASE DEFAULT
2453 : !!!!! write (unit=*,fmt=*) "Assertion failed"
2454 : !!!!! STOP
2455 : !
2456 : ! We make a special case when we have so few values in
2457 : ! the high values set that it is bad performance to choose a pivot
2458 : ! and apply the general algorithm.
2459 : !
2460 : Case (2)
2461 0 : If (XDONT(IHIGT(1)) <= XDONT(IHIGT(2))) Then
2462 0 : JLOW = JLOW + 1
2463 0 : ILOWT (JLOW) = IHIGT (1)
2464 0 : JLOW = JLOW + 1
2465 0 : ILOWT (JLOW) = IHIGT (2)
2466 : Else
2467 0 : JLOW = JLOW + 1
2468 0 : ILOWT (JLOW) = IHIGT (2)
2469 0 : JLOW = JLOW + 1
2470 0 : ILOWT (JLOW) = IHIGT (1)
2471 : End If
2472 : Exit
2473 : !
2474 : Case (3)
2475 : !
2476 : !
2477 0 : IWRK1 = IHIGT (1)
2478 0 : IWRK2 = IHIGT (2)
2479 0 : IWRK3 = IHIGT (3)
2480 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
2481 0 : IHIGT (1) = IWRK2
2482 0 : IHIGT (2) = IWRK1
2483 0 : IWRK2 = IWRK1
2484 : End If
2485 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
2486 0 : IHIGT (3) = IWRK2
2487 0 : IHIGT (2) = IWRK3
2488 0 : IWRK2 = IWRK3
2489 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
2490 0 : IHIGT (2) = IHIGT (1)
2491 0 : IHIGT (1) = IWRK2
2492 : End If
2493 : End If
2494 : JHIG = 0
2495 0 : Do ICRS = JLOW + 1, INTH
2496 0 : JHIG = JHIG + 1
2497 0 : ILOWT (ICRS) = IHIGT (JHIG)
2498 : End Do
2499 0 : JLOW = INTH
2500 : Exit
2501 : !
2502 : Case (4 :)
2503 : !
2504 : !
2505 0 : IFIN = JHIG
2506 : !
2507 : ! One chooses a pivot from the 2 first values and the last one.
2508 : ! This should ensure sufficient renewal between iterations to
2509 : ! avoid worst case behavior effects.
2510 : !
2511 0 : IWRK1 = IHIGT (1)
2512 0 : IWRK2 = IHIGT (2)
2513 0 : IWRK3 = IHIGT (IFIN)
2514 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
2515 0 : IHIGT (1) = IWRK2
2516 0 : IHIGT (2) = IWRK1
2517 0 : IWRK2 = IWRK1
2518 : End If
2519 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
2520 0 : IHIGT (IFIN) = IWRK2
2521 0 : IHIGT (2) = IWRK3
2522 0 : IWRK2 = IWRK3
2523 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
2524 0 : IHIGT (2) = IHIGT (1)
2525 0 : IHIGT (1) = IWRK2
2526 : End If
2527 : End If
2528 : !
2529 0 : IWRK1 = IHIGT (1)
2530 0 : JLOW = JLOW + 1
2531 0 : ILOWT (JLOW) = IWRK1
2532 0 : XPIV = XDONT (IWRK1) + 0.5 * (XDONT(IHIGT(IFIN)) - XDONT(IWRK1))
2533 : !
2534 : ! One takes values <= pivot to ILOWT
2535 : ! Again, 2 parts, one where we take care of the remaining
2536 : ! high values because we might still need them, and the
2537 : ! other when we know that we will have more than enough
2538 : ! low values in the end.
2539 : !
2540 0 : JHIG = 0
2541 0 : Do ICRS = 2, IFIN
2542 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
2543 0 : JLOW = JLOW + 1
2544 0 : ILOWT (JLOW) = IHIGT (ICRS)
2545 0 : If (JLOW >= INTH) Exit
2546 : Else
2547 0 : JHIG = JHIG + 1
2548 0 : IHIGT (JHIG) = IHIGT (ICRS)
2549 : End If
2550 : End Do
2551 : !
2552 0 : Do ICRS = ICRS + 1, IFIN
2553 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
2554 0 : JLOW = JLOW + 1
2555 0 : ILOWT (JLOW) = IHIGT (ICRS)
2556 : End If
2557 : End Do
2558 : End Select
2559 : !
2560 : !
2561 : Case (1)
2562 : !
2563 : ! Only 1 value is missing in low part
2564 : !
2565 0 : XMIN = XDONT (IHIGT(1))
2566 0 : IHIG = 1
2567 0 : Do ICRS = 2, JHIG
2568 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
2569 0 : XMIN = XDONT (IHIGT(ICRS))
2570 0 : IHIG = ICRS
2571 : End If
2572 : End Do
2573 : !
2574 0 : INDNTH = IHIGT (IHIG)
2575 0 : Return
2576 : !
2577 : !
2578 : Case (0)
2579 : !
2580 : ! Low part is exactly what we want
2581 : !
2582 0 : Exit
2583 : !
2584 : !
2585 : Case (-5 : -1)
2586 : !
2587 : ! Only few values too many in low part
2588 : !
2589 0 : IRNGT (1) = ILOWT (1)
2590 0 : ILOW = 1 + INTH - JLOW
2591 0 : Do ICRS = 2, INTH
2592 0 : IWRK = ILOWT (ICRS)
2593 0 : XWRK = XDONT (IWRK)
2594 0 : Do IDCR = ICRS - 1, MAX (1, ILOW), - 1
2595 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
2596 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
2597 : Else
2598 : Exit
2599 : End If
2600 : End Do
2601 0 : IRNGT (IDCR + 1) = IWRK
2602 0 : ILOW = ILOW + 1
2603 : End Do
2604 : !
2605 0 : XWRK1 = XDONT (IRNGT(INTH))
2606 0 : ILOW = 2 * INTH - JLOW
2607 0 : Do ICRS = INTH + 1, JLOW
2608 0 : If (XDONT(ILOWT (ICRS)) < XWRK1) Then
2609 0 : XWRK = XDONT (ILOWT (ICRS))
2610 0 : Do IDCR = INTH - 1, MAX (1, ILOW), - 1
2611 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
2612 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
2613 : End Do
2614 0 : IRNGT (IDCR + 1) = ILOWT (ICRS)
2615 0 : XWRK1 = XDONT (IRNGT(INTH))
2616 : End If
2617 0 : ILOW = ILOW + 1
2618 : End Do
2619 : !
2620 0 : INDNTH = IRNGT(INTH)
2621 0 : Return
2622 : !
2623 : !
2624 : Case (: -6)
2625 : !
2626 : ! last case: too many values in low part
2627 : !
2628 :
2629 0 : IMIL = (JLOW + 1) / 2
2630 0 : IFIN = JLOW
2631 : !
2632 : ! One chooses a pivot from 1st, last, and middle values
2633 : !
2634 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(1))) Then
2635 0 : IWRK = ILOWT (1)
2636 0 : ILOWT (1) = ILOWT (IMIL)
2637 0 : ILOWT (IMIL) = IWRK
2638 : End If
2639 0 : If (XDONT(ILOWT(IMIL)) > XDONT(ILOWT(IFIN))) Then
2640 0 : IWRK = ILOWT (IFIN)
2641 0 : ILOWT (IFIN) = ILOWT (IMIL)
2642 0 : ILOWT (IMIL) = IWRK
2643 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(1))) Then
2644 0 : IWRK = ILOWT (1)
2645 0 : ILOWT (1) = ILOWT (IMIL)
2646 0 : ILOWT (IMIL) = IWRK
2647 : End If
2648 : End If
2649 0 : If (IFIN <= 3) Exit
2650 : !
2651 0 : XPIV = XDONT (ILOWT(1)) + REAL(INTH, dp) / REAL(JLOW + INTH, dp) * &
2652 0 : (XDONT(ILOWT(IFIN)) - XDONT(ILOWT(1)))
2653 :
2654 : !
2655 : ! One takes values > XPIV to IHIGT
2656 : !
2657 0 : JHIG = 0
2658 0 : JLOW = 0
2659 : !
2660 0 : If (XDONT(ILOWT(IFIN)) > XPIV) Then
2661 : ICRS = 0
2662 : Do
2663 0 : ICRS = ICRS + 1
2664 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
2665 0 : JHIG = JHIG + 1
2666 0 : IHIGT (JHIG) = ILOWT (ICRS)
2667 0 : If (ICRS >= IFIN) Exit
2668 : Else
2669 0 : JLOW = JLOW + 1
2670 0 : ILOWT (JLOW) = ILOWT (ICRS)
2671 0 : If (JLOW >= INTH) Exit
2672 : End If
2673 : End Do
2674 : !
2675 0 : If (ICRS < IFIN) Then
2676 : Do
2677 0 : ICRS = ICRS + 1
2678 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
2679 0 : JLOW = JLOW + 1
2680 0 : ILOWT (JLOW) = ILOWT (ICRS)
2681 : Else
2682 0 : If (ICRS >= IFIN) Exit
2683 : End If
2684 : End Do
2685 : End If
2686 : Else
2687 0 : Do ICRS = 1, IFIN
2688 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
2689 0 : JHIG = JHIG + 1
2690 0 : IHIGT (JHIG) = ILOWT (ICRS)
2691 : Else
2692 0 : JLOW = JLOW + 1
2693 0 : ILOWT (JLOW) = ILOWT (ICRS)
2694 0 : If (JLOW >= INTH) Exit
2695 : End If
2696 : End Do
2697 : !
2698 0 : Do ICRS = ICRS + 1, IFIN
2699 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
2700 0 : JLOW = JLOW + 1
2701 0 : ILOWT (JLOW) = ILOWT (ICRS)
2702 : End If
2703 : End Do
2704 : End If
2705 : !
2706 : End Select
2707 : !
2708 : End Do
2709 : !
2710 : ! Now, we only need to find maximum of the 1:INTH set
2711 : !
2712 :
2713 0 : IWRK1 = ILOWT (1)
2714 0 : XWRK1 = XDONT (IWRK1)
2715 0 : Do ICRS = 1 + 1, INTH
2716 0 : IWRK = ILOWT (ICRS)
2717 0 : XWRK = XDONT (IWRK)
2718 0 : If (XWRK > XWRK1) Then
2719 0 : XWRK1 = XWRK
2720 0 : IWRK1 = IWRK
2721 : End If
2722 : End Do
2723 0 : INDNTH = IWRK1
2724 : Return
2725 : !
2726 : !
2727 0 : End Function D_indnth
2728 :
2729 0 : Function R_indnth (XDONT, NORD) Result (INDNTH)
2730 : ! Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
2731 : ! __________________________________________________________
2732 : ! This routine uses a pivoting strategy such as the one of
2733 : ! finding the median based on the quicksort algorithm, but
2734 : ! we skew the pivot choice to try to bring it to NORD as
2735 : ! fast as possible. It uses 2 temporary arrays, where it
2736 : ! stores the indices of the values smaller than the pivot
2737 : ! (ILOWT), and the indices of values larger than the pivot
2738 : ! that we might still need later on (IHIGT). It iterates
2739 : ! until it can bring the number of values in ILOWT to
2740 : ! exactly NORD, and then finds the maximum of this set.
2741 : ! Michel Olagnon - Aug. 2000
2742 : ! __________________________________________________________
2743 : ! _________________________________________________________
2744 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
2745 : Integer(kind = i4) :: INDNTH
2746 : Integer(kind = i4), Intent (In) :: NORD
2747 : ! __________________________________________________________
2748 0 : Real(kind = sp) :: XPIV, XWRK, XWRK1, XMIN, XMAX
2749 : !
2750 0 : Integer(kind = i4), Dimension (NORD) :: IRNGT
2751 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
2752 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
2753 : Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
2754 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
2755 : !
2756 0 : NDON = SIZE (XDONT)
2757 0 : INTH = NORD
2758 : !
2759 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
2760 : !
2761 0 : If (NDON < 2) Then
2762 : If (INTH == 1) INDNTH = 1
2763 : Return
2764 : End If
2765 : !
2766 : ! One chooses a pivot, best estimate possible to put fractile near
2767 : ! mid-point of the set of low values.
2768 : !
2769 0 : If (XDONT(2) < XDONT(1)) Then
2770 0 : ILOWT (1) = 2
2771 0 : IHIGT (1) = 1
2772 : Else
2773 0 : ILOWT (1) = 1
2774 0 : IHIGT (1) = 2
2775 : End If
2776 : !
2777 0 : If (NDON < 3) Then
2778 0 : If (INTH == 1) INDNTH = ILOWT (1)
2779 0 : If (INTH == 2) INDNTH = IHIGT (1)
2780 0 : Return
2781 : End If
2782 : !
2783 0 : If (XDONT(3) < XDONT(IHIGT(1))) Then
2784 0 : IHIGT (2) = IHIGT (1)
2785 0 : If (XDONT(3) < XDONT(ILOWT(1))) Then
2786 0 : IHIGT (1) = ILOWT (1)
2787 0 : ILOWT (1) = 3
2788 : Else
2789 0 : IHIGT (1) = 3
2790 : End If
2791 : Else
2792 0 : IHIGT (2) = 3
2793 : End If
2794 : !
2795 0 : If (NDON < 4) Then
2796 0 : If (INTH == 1) INDNTH = ILOWT (1)
2797 0 : If (INTH == 2) INDNTH = IHIGT (1)
2798 0 : If (INTH == 3) INDNTH = IHIGT (2)
2799 0 : Return
2800 : End If
2801 : !
2802 0 : If (XDONT(NDON) < XDONT(IHIGT(1))) Then
2803 0 : IHIGT (3) = IHIGT (2)
2804 0 : IHIGT (2) = IHIGT (1)
2805 0 : If (XDONT(NDON) < XDONT(ILOWT(1))) Then
2806 0 : IHIGT (1) = ILOWT (1)
2807 0 : ILOWT (1) = NDON
2808 : Else
2809 0 : IHIGT (1) = NDON
2810 : End If
2811 : Else
2812 0 : IHIGT (3) = NDON
2813 : End If
2814 : !
2815 0 : If (NDON < 5) Then
2816 0 : If (INTH == 1) INDNTH = ILOWT (1)
2817 0 : If (INTH == 2) INDNTH = IHIGT (1)
2818 0 : If (INTH == 3) INDNTH = IHIGT (2)
2819 0 : If (INTH == 4) INDNTH = IHIGT (3)
2820 0 : Return
2821 : End If
2822 : !
2823 :
2824 0 : JLOW = 1
2825 0 : JHIG = 3
2826 0 : XPIV = XDONT (ILOWT(1)) + REAL(2 * INTH, sp) / REAL(NDON + INTH, sp) * &
2827 0 : (XDONT(IHIGT(3)) - XDONT(ILOWT(1)))
2828 0 : If (XPIV >= XDONT(IHIGT(1))) Then
2829 : XPIV = XDONT (ILOWT(1)) + REAL(2 * INTH, sp) / REAL(NDON + INTH, sp) * &
2830 0 : (XDONT(IHIGT(2)) - XDONT(ILOWT(1)))
2831 0 : If (XPIV >= XDONT(IHIGT(1))) &
2832 : XPIV = XDONT (ILOWT(1)) + REAL(2 * INTH, sp) / REAL(NDON + INTH, sp) * &
2833 0 : (XDONT(IHIGT(1)) - XDONT(ILOWT(1)))
2834 : End If
2835 : !
2836 : ! One puts values > pivot in the end and those <= pivot
2837 : ! at the beginning. This is split in 2 cases, so that
2838 : ! we can skip the loop test a number of times.
2839 : ! As we are also filling in the work arrays at the same time
2840 : ! we stop filling in the IHIGT array as soon as we have more
2841 : ! than enough values in ILOWT.
2842 : !
2843 : !
2844 0 : If (XDONT(NDON) > XPIV) Then
2845 : ICRS = 3
2846 : Do
2847 0 : ICRS = ICRS + 1
2848 0 : If (XDONT(ICRS) > XPIV) Then
2849 0 : If (ICRS >= NDON) Exit
2850 0 : JHIG = JHIG + 1
2851 0 : IHIGT (JHIG) = ICRS
2852 : Else
2853 0 : JLOW = JLOW + 1
2854 0 : ILOWT (JLOW) = ICRS
2855 0 : If (JLOW >= INTH) Exit
2856 : End If
2857 : End Do
2858 : !
2859 : ! One restricts further processing because it is no use
2860 : ! to store more high values
2861 : !
2862 0 : If (ICRS < NDON - 1) Then
2863 : Do
2864 0 : ICRS = ICRS + 1
2865 0 : If (XDONT(ICRS) <= XPIV) Then
2866 0 : JLOW = JLOW + 1
2867 0 : ILOWT (JLOW) = ICRS
2868 0 : Else If (ICRS >= NDON) Then
2869 : Exit
2870 : End If
2871 : End Do
2872 : End If
2873 : !
2874 : !
2875 : Else
2876 : !
2877 : ! Same as above, but this is not as easy to optimize, so the
2878 : ! DO-loop is kept
2879 : !
2880 0 : Do ICRS = 4, NDON - 1
2881 0 : If (XDONT(ICRS) > XPIV) Then
2882 0 : JHIG = JHIG + 1
2883 0 : IHIGT (JHIG) = ICRS
2884 : Else
2885 0 : JLOW = JLOW + 1
2886 0 : ILOWT (JLOW) = ICRS
2887 0 : If (JLOW >= INTH) Exit
2888 : End If
2889 : End Do
2890 : !
2891 0 : If (ICRS < NDON - 1) Then
2892 : Do
2893 0 : ICRS = ICRS + 1
2894 0 : If (XDONT(ICRS) <= XPIV) Then
2895 0 : If (ICRS >= NDON) Exit
2896 0 : JLOW = JLOW + 1
2897 0 : ILOWT (JLOW) = ICRS
2898 : End If
2899 : End Do
2900 : End If
2901 : End If
2902 : !
2903 : JLM2 = 0
2904 : JLM1 = 0
2905 : JHM2 = 0
2906 : JHM1 = 0
2907 : Do
2908 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
2909 : !
2910 : ! We are oscillating. Perturbate by bringing JLOW closer by one
2911 : ! to INTH
2912 : !
2913 0 : If (INTH > JLOW) Then
2914 0 : XMIN = XDONT (IHIGT(1))
2915 0 : IHIG = 1
2916 0 : Do ICRS = 2, JHIG
2917 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
2918 0 : XMIN = XDONT (IHIGT(ICRS))
2919 0 : IHIG = ICRS
2920 : End If
2921 : End Do
2922 : !
2923 0 : JLOW = JLOW + 1
2924 0 : ILOWT (JLOW) = IHIGT (IHIG)
2925 0 : IHIGT (IHIG) = IHIGT (JHIG)
2926 0 : JHIG = JHIG - 1
2927 : Else
2928 :
2929 0 : ILOW = ILOWT (1)
2930 0 : XMAX = XDONT (ILOW)
2931 0 : Do ICRS = 2, JLOW
2932 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
2933 0 : IWRK = ILOWT (ICRS)
2934 0 : XMAX = XDONT (IWRK)
2935 0 : ILOWT (ICRS) = ILOW
2936 0 : ILOW = IWRK
2937 : End If
2938 : End Do
2939 0 : JLOW = JLOW - 1
2940 : End If
2941 : End If
2942 0 : JLM2 = JLM1
2943 0 : JLM1 = JLOW
2944 0 : JHM2 = JHM1
2945 0 : JHM1 = JHIG
2946 : !
2947 : ! We try to bring the number of values in the low values set
2948 : ! closer to INTH.
2949 : !
2950 0 : Select Case (INTH - JLOW)
2951 : Case (2 :)
2952 : !
2953 : ! Not enough values in low part, at least 2 are missing
2954 : !
2955 0 : INTH = INTH - JLOW
2956 0 : JLOW = 0
2957 : Select Case (JHIG)
2958 : !!!!! CASE DEFAULT
2959 : !!!!! write (unit=*,fmt=*) "Assertion failed"
2960 : !!!!! STOP
2961 : !
2962 : ! We make a special case when we have so few values in
2963 : ! the high values set that it is bad performance to choose a pivot
2964 : ! and apply the general algorithm.
2965 : !
2966 : Case (2)
2967 0 : If (XDONT(IHIGT(1)) <= XDONT(IHIGT(2))) Then
2968 0 : JLOW = JLOW + 1
2969 0 : ILOWT (JLOW) = IHIGT (1)
2970 0 : JLOW = JLOW + 1
2971 0 : ILOWT (JLOW) = IHIGT (2)
2972 : Else
2973 0 : JLOW = JLOW + 1
2974 0 : ILOWT (JLOW) = IHIGT (2)
2975 0 : JLOW = JLOW + 1
2976 0 : ILOWT (JLOW) = IHIGT (1)
2977 : End If
2978 : Exit
2979 : !
2980 : Case (3)
2981 : !
2982 : !
2983 0 : IWRK1 = IHIGT (1)
2984 0 : IWRK2 = IHIGT (2)
2985 0 : IWRK3 = IHIGT (3)
2986 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
2987 0 : IHIGT (1) = IWRK2
2988 0 : IHIGT (2) = IWRK1
2989 0 : IWRK2 = IWRK1
2990 : End If
2991 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
2992 0 : IHIGT (3) = IWRK2
2993 0 : IHIGT (2) = IWRK3
2994 0 : IWRK2 = IWRK3
2995 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
2996 0 : IHIGT (2) = IHIGT (1)
2997 0 : IHIGT (1) = IWRK2
2998 : End If
2999 : End If
3000 : JHIG = 0
3001 0 : Do ICRS = JLOW + 1, INTH
3002 0 : JHIG = JHIG + 1
3003 0 : ILOWT (ICRS) = IHIGT (JHIG)
3004 : End Do
3005 0 : JLOW = INTH
3006 : Exit
3007 : !
3008 : Case (4 :)
3009 : !
3010 : !
3011 0 : IFIN = JHIG
3012 : !
3013 : ! One chooses a pivot from the 2 first values and the last one.
3014 : ! This should ensure sufficient renewal between iterations to
3015 : ! avoid worst case behavior effects.
3016 : !
3017 0 : IWRK1 = IHIGT (1)
3018 0 : IWRK2 = IHIGT (2)
3019 0 : IWRK3 = IHIGT (IFIN)
3020 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
3021 0 : IHIGT (1) = IWRK2
3022 0 : IHIGT (2) = IWRK1
3023 0 : IWRK2 = IWRK1
3024 : End If
3025 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
3026 0 : IHIGT (IFIN) = IWRK2
3027 0 : IHIGT (2) = IWRK3
3028 0 : IWRK2 = IWRK3
3029 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
3030 0 : IHIGT (2) = IHIGT (1)
3031 0 : IHIGT (1) = IWRK2
3032 : End If
3033 : End If
3034 : !
3035 0 : IWRK1 = IHIGT (1)
3036 0 : JLOW = JLOW + 1
3037 0 : ILOWT (JLOW) = IWRK1
3038 0 : XPIV = XDONT (IWRK1) + 0.5 * (XDONT(IHIGT(IFIN)) - XDONT(IWRK1))
3039 : !
3040 : ! One takes values <= pivot to ILOWT
3041 : ! Again, 2 parts, one where we take care of the remaining
3042 : ! high values because we might still need them, and the
3043 : ! other when we know that we will have more than enough
3044 : ! low values in the end.
3045 : !
3046 0 : JHIG = 0
3047 0 : Do ICRS = 2, IFIN
3048 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
3049 0 : JLOW = JLOW + 1
3050 0 : ILOWT (JLOW) = IHIGT (ICRS)
3051 0 : If (JLOW >= INTH) Exit
3052 : Else
3053 0 : JHIG = JHIG + 1
3054 0 : IHIGT (JHIG) = IHIGT (ICRS)
3055 : End If
3056 : End Do
3057 : !
3058 0 : Do ICRS = ICRS + 1, IFIN
3059 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
3060 0 : JLOW = JLOW + 1
3061 0 : ILOWT (JLOW) = IHIGT (ICRS)
3062 : End If
3063 : End Do
3064 : End Select
3065 : !
3066 : !
3067 : Case (1)
3068 : !
3069 : ! Only 1 value is missing in low part
3070 : !
3071 0 : XMIN = XDONT (IHIGT(1))
3072 0 : IHIG = 1
3073 0 : Do ICRS = 2, JHIG
3074 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
3075 0 : XMIN = XDONT (IHIGT(ICRS))
3076 0 : IHIG = ICRS
3077 : End If
3078 : End Do
3079 : !
3080 0 : INDNTH = IHIGT (IHIG)
3081 0 : Return
3082 : !
3083 : !
3084 : Case (0)
3085 : !
3086 : ! Low part is exactly what we want
3087 : !
3088 0 : Exit
3089 : !
3090 : !
3091 : Case (-5 : -1)
3092 : !
3093 : ! Only few values too many in low part
3094 : !
3095 0 : IRNGT (1) = ILOWT (1)
3096 0 : ILOW = 1 + INTH - JLOW
3097 0 : Do ICRS = 2, INTH
3098 0 : IWRK = ILOWT (ICRS)
3099 0 : XWRK = XDONT (IWRK)
3100 0 : Do IDCR = ICRS - 1, MAX (1, ILOW), - 1
3101 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
3102 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
3103 : Else
3104 : Exit
3105 : End If
3106 : End Do
3107 0 : IRNGT (IDCR + 1) = IWRK
3108 0 : ILOW = ILOW + 1
3109 : End Do
3110 : !
3111 0 : XWRK1 = XDONT (IRNGT(INTH))
3112 0 : ILOW = 2 * INTH - JLOW
3113 0 : Do ICRS = INTH + 1, JLOW
3114 0 : If (XDONT(ILOWT (ICRS)) < XWRK1) Then
3115 0 : XWRK = XDONT (ILOWT (ICRS))
3116 0 : Do IDCR = INTH - 1, MAX (1, ILOW), - 1
3117 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
3118 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
3119 : End Do
3120 0 : IRNGT (IDCR + 1) = ILOWT (ICRS)
3121 0 : XWRK1 = XDONT (IRNGT(INTH))
3122 : End If
3123 0 : ILOW = ILOW + 1
3124 : End Do
3125 : !
3126 0 : INDNTH = IRNGT(INTH)
3127 0 : Return
3128 : !
3129 : !
3130 : Case (: -6)
3131 : !
3132 : ! last case: too many values in low part
3133 : !
3134 :
3135 0 : IMIL = (JLOW + 1) / 2
3136 0 : IFIN = JLOW
3137 : !
3138 : ! One chooses a pivot from 1st, last, and middle values
3139 : !
3140 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(1))) Then
3141 0 : IWRK = ILOWT (1)
3142 0 : ILOWT (1) = ILOWT (IMIL)
3143 0 : ILOWT (IMIL) = IWRK
3144 : End If
3145 0 : If (XDONT(ILOWT(IMIL)) > XDONT(ILOWT(IFIN))) Then
3146 0 : IWRK = ILOWT (IFIN)
3147 0 : ILOWT (IFIN) = ILOWT (IMIL)
3148 0 : ILOWT (IMIL) = IWRK
3149 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(1))) Then
3150 0 : IWRK = ILOWT (1)
3151 0 : ILOWT (1) = ILOWT (IMIL)
3152 0 : ILOWT (IMIL) = IWRK
3153 : End If
3154 : End If
3155 0 : If (IFIN <= 3) Exit
3156 : !
3157 0 : XPIV = XDONT (ILOWT(1)) + REAL(INTH, sp) / REAL(JLOW + INTH, sp) * &
3158 0 : (XDONT(ILOWT(IFIN)) - XDONT(ILOWT(1)))
3159 :
3160 : !
3161 : ! One takes values > XPIV to IHIGT
3162 : !
3163 0 : JHIG = 0
3164 0 : JLOW = 0
3165 : !
3166 0 : If (XDONT(ILOWT(IFIN)) > XPIV) Then
3167 : ICRS = 0
3168 : Do
3169 0 : ICRS = ICRS + 1
3170 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
3171 0 : JHIG = JHIG + 1
3172 0 : IHIGT (JHIG) = ILOWT (ICRS)
3173 0 : If (ICRS >= IFIN) Exit
3174 : Else
3175 0 : JLOW = JLOW + 1
3176 0 : ILOWT (JLOW) = ILOWT (ICRS)
3177 0 : If (JLOW >= INTH) Exit
3178 : End If
3179 : End Do
3180 : !
3181 0 : If (ICRS < IFIN) Then
3182 : Do
3183 0 : ICRS = ICRS + 1
3184 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
3185 0 : JLOW = JLOW + 1
3186 0 : ILOWT (JLOW) = ILOWT (ICRS)
3187 : Else
3188 0 : If (ICRS >= IFIN) Exit
3189 : End If
3190 : End Do
3191 : End If
3192 : Else
3193 0 : Do ICRS = 1, IFIN
3194 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
3195 0 : JHIG = JHIG + 1
3196 0 : IHIGT (JHIG) = ILOWT (ICRS)
3197 : Else
3198 0 : JLOW = JLOW + 1
3199 0 : ILOWT (JLOW) = ILOWT (ICRS)
3200 0 : If (JLOW >= INTH) Exit
3201 : End If
3202 : End Do
3203 : !
3204 0 : Do ICRS = ICRS + 1, IFIN
3205 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
3206 0 : JLOW = JLOW + 1
3207 0 : ILOWT (JLOW) = ILOWT (ICRS)
3208 : End If
3209 : End Do
3210 : End If
3211 : !
3212 : End Select
3213 : !
3214 : End Do
3215 : !
3216 : ! Now, we only need to find maximum of the 1:INTH set
3217 : !
3218 :
3219 0 : IWRK1 = ILOWT (1)
3220 0 : XWRK1 = XDONT (IWRK1)
3221 0 : Do ICRS = 1 + 1, INTH
3222 0 : IWRK = ILOWT (ICRS)
3223 0 : XWRK = XDONT (IWRK)
3224 0 : If (XWRK > XWRK1) Then
3225 0 : XWRK1 = XWRK
3226 0 : IWRK1 = IWRK
3227 : End If
3228 : End Do
3229 0 : INDNTH = IWRK1
3230 : Return
3231 : !
3232 : !
3233 0 : End Function R_indnth
3234 :
3235 0 : Function I_indnth (XDONT, NORD) Result (INDNTH)
3236 : ! Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
3237 : ! __________________________________________________________
3238 : ! This routine uses a pivoting strategy such as the one of
3239 : ! finding the median based on the quicksort algorithm, but
3240 : ! we skew the pivot choice to try to bring it to NORD as
3241 : ! fast as possible. It uses 2 temporary arrays, where it
3242 : ! stores the indices of the values smaller than the pivot
3243 : ! (ILOWT), and the indices of values larger than the pivot
3244 : ! that we might still need later on (IHIGT). It iterates
3245 : ! until it can bring the number of values in ILOWT to
3246 : ! exactly NORD, and then finds the maximum of this set.
3247 : ! Michel Olagnon - Aug. 2000
3248 : ! __________________________________________________________
3249 : ! __________________________________________________________
3250 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
3251 : Integer(kind = i4) :: INDNTH
3252 : Integer(kind = i4), Intent (In) :: NORD
3253 : ! __________________________________________________________
3254 : Integer(kind = i4) :: XPIV, XWRK, XWRK1, XMIN, XMAX
3255 : !
3256 0 : Integer(kind = i4), Dimension (NORD) :: IRNGT
3257 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
3258 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
3259 : Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
3260 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
3261 : !
3262 0 : NDON = SIZE (XDONT)
3263 0 : INTH = NORD
3264 : !
3265 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
3266 : !
3267 0 : If (NDON < 2) Then
3268 : If (INTH == 1) INDNTH = 1
3269 : Return
3270 : End If
3271 : !
3272 : ! One chooses a pivot, best estimate possible to put fractile near
3273 : ! mid-point of the set of low values.
3274 : !
3275 0 : If (XDONT(2) < XDONT(1)) Then
3276 0 : ILOWT (1) = 2
3277 0 : IHIGT (1) = 1
3278 : Else
3279 0 : ILOWT (1) = 1
3280 0 : IHIGT (1) = 2
3281 : End If
3282 : !
3283 0 : If (NDON < 3) Then
3284 0 : If (INTH == 1) INDNTH = ILOWT (1)
3285 0 : If (INTH == 2) INDNTH = IHIGT (1)
3286 0 : Return
3287 : End If
3288 : !
3289 0 : If (XDONT(3) < XDONT(IHIGT(1))) Then
3290 0 : IHIGT (2) = IHIGT (1)
3291 0 : If (XDONT(3) < XDONT(ILOWT(1))) Then
3292 0 : IHIGT (1) = ILOWT (1)
3293 0 : ILOWT (1) = 3
3294 : Else
3295 0 : IHIGT (1) = 3
3296 : End If
3297 : Else
3298 0 : IHIGT (2) = 3
3299 : End If
3300 : !
3301 0 : If (NDON < 4) Then
3302 0 : If (INTH == 1) INDNTH = ILOWT (1)
3303 0 : If (INTH == 2) INDNTH = IHIGT (1)
3304 0 : If (INTH == 3) INDNTH = IHIGT (2)
3305 0 : Return
3306 : End If
3307 : !
3308 0 : If (XDONT(NDON) < XDONT(IHIGT(1))) Then
3309 0 : IHIGT (3) = IHIGT (2)
3310 0 : IHIGT (2) = IHIGT (1)
3311 0 : If (XDONT(NDON) < XDONT(ILOWT(1))) Then
3312 0 : IHIGT (1) = ILOWT (1)
3313 0 : ILOWT (1) = NDON
3314 : Else
3315 0 : IHIGT (1) = NDON
3316 : End If
3317 : Else
3318 0 : IHIGT (3) = NDON
3319 : End If
3320 : !
3321 0 : If (NDON < 5) Then
3322 0 : If (INTH == 1) INDNTH = ILOWT (1)
3323 0 : If (INTH == 2) INDNTH = IHIGT (1)
3324 0 : If (INTH == 3) INDNTH = IHIGT (2)
3325 0 : If (INTH == 4) INDNTH = IHIGT (3)
3326 0 : Return
3327 : End If
3328 : !
3329 :
3330 0 : JLOW = 1
3331 0 : JHIG = 3
3332 0 : XPIV = XDONT (ILOWT(1)) + INT(REAL(2 * INTH, sp) / REAL(NDON + INTH, sp), i4) * &
3333 0 : (XDONT(IHIGT(3)) - XDONT(ILOWT(1)))
3334 0 : If (XPIV >= XDONT(IHIGT(1))) Then
3335 : XPIV = XDONT (ILOWT(1)) + INT(REAL(2 * INTH, sp) / REAL(NDON + INTH, sp), i4) * &
3336 0 : (XDONT(IHIGT(2)) - XDONT(ILOWT(1)))
3337 0 : If (XPIV >= XDONT(IHIGT(1))) &
3338 : XPIV = XDONT (ILOWT(1)) + INT(REAL(2 * INTH, sp) / REAL(NDON + INTH, sp), i4) * &
3339 0 : (XDONT(IHIGT(1)) - XDONT(ILOWT(1)))
3340 : End If
3341 : !
3342 : ! One puts values > pivot in the end and those <= pivot
3343 : ! at the beginning. This is split in 2 cases, so that
3344 : ! we can skip the loop test a number of times.
3345 : ! As we are also filling in the work arrays at the same time
3346 : ! we stop filling in the IHIGT array as soon as we have more
3347 : ! than enough values in ILOWT.
3348 : !
3349 : !
3350 0 : If (XDONT(NDON) > XPIV) Then
3351 : ICRS = 3
3352 : Do
3353 0 : ICRS = ICRS + 1
3354 0 : If (XDONT(ICRS) > XPIV) Then
3355 0 : If (ICRS >= NDON) Exit
3356 0 : JHIG = JHIG + 1
3357 0 : IHIGT (JHIG) = ICRS
3358 : Else
3359 0 : JLOW = JLOW + 1
3360 0 : ILOWT (JLOW) = ICRS
3361 0 : If (JLOW >= INTH) Exit
3362 : End If
3363 : End Do
3364 : !
3365 : ! One restricts further processing because it is no use
3366 : ! to store more high values
3367 : !
3368 0 : If (ICRS < NDON - 1) Then
3369 : Do
3370 0 : ICRS = ICRS + 1
3371 0 : If (XDONT(ICRS) <= XPIV) Then
3372 0 : JLOW = JLOW + 1
3373 0 : ILOWT (JLOW) = ICRS
3374 0 : Else If (ICRS >= NDON) Then
3375 : Exit
3376 : End If
3377 : End Do
3378 : End If
3379 : !
3380 : !
3381 : Else
3382 : !
3383 : ! Same as above, but this is not as easy to optimize, so the
3384 : ! DO-loop is kept
3385 : !
3386 0 : Do ICRS = 4, NDON - 1
3387 0 : If (XDONT(ICRS) > XPIV) Then
3388 0 : JHIG = JHIG + 1
3389 0 : IHIGT (JHIG) = ICRS
3390 : Else
3391 0 : JLOW = JLOW + 1
3392 0 : ILOWT (JLOW) = ICRS
3393 0 : If (JLOW >= INTH) Exit
3394 : End If
3395 : End Do
3396 : !
3397 0 : If (ICRS < NDON - 1) Then
3398 : Do
3399 0 : ICRS = ICRS + 1
3400 0 : If (XDONT(ICRS) <= XPIV) Then
3401 0 : If (ICRS >= NDON) Exit
3402 0 : JLOW = JLOW + 1
3403 0 : ILOWT (JLOW) = ICRS
3404 : End If
3405 : End Do
3406 : End If
3407 : End If
3408 : !
3409 : JLM2 = 0
3410 : JLM1 = 0
3411 : JHM2 = 0
3412 : JHM1 = 0
3413 : Do
3414 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
3415 : !
3416 : ! We are oscillating. Perturbate by bringing JLOW closer by one
3417 : ! to INTH
3418 : !
3419 0 : If (INTH > JLOW) Then
3420 0 : XMIN = XDONT (IHIGT(1))
3421 0 : IHIG = 1
3422 0 : Do ICRS = 2, JHIG
3423 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
3424 0 : XMIN = XDONT (IHIGT(ICRS))
3425 0 : IHIG = ICRS
3426 : End If
3427 : End Do
3428 : !
3429 0 : JLOW = JLOW + 1
3430 0 : ILOWT (JLOW) = IHIGT (IHIG)
3431 0 : IHIGT (IHIG) = IHIGT (JHIG)
3432 0 : JHIG = JHIG - 1
3433 : Else
3434 :
3435 0 : ILOW = ILOWT (1)
3436 0 : XMAX = XDONT (ILOW)
3437 0 : Do ICRS = 2, JLOW
3438 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
3439 0 : IWRK = ILOWT (ICRS)
3440 0 : XMAX = XDONT (IWRK)
3441 0 : ILOWT (ICRS) = ILOW
3442 0 : ILOW = IWRK
3443 : End If
3444 : End Do
3445 0 : JLOW = JLOW - 1
3446 : End If
3447 : End If
3448 0 : JLM2 = JLM1
3449 0 : JLM1 = JLOW
3450 0 : JHM2 = JHM1
3451 0 : JHM1 = JHIG
3452 : !
3453 : ! We try to bring the number of values in the low values set
3454 : ! closer to INTH.
3455 : !
3456 0 : Select Case (INTH - JLOW)
3457 : Case (2 :)
3458 : !
3459 : ! Not enough values in low part, at least 2 are missing
3460 : !
3461 0 : INTH = INTH - JLOW
3462 0 : JLOW = 0
3463 : Select Case (JHIG)
3464 : !!!!! CASE DEFAULT
3465 : !!!!! write (unit=*,fmt=*) "Assertion failed"
3466 : !!!!! STOP
3467 : !
3468 : ! We make a special case when we have so few values in
3469 : ! the high values set that it is bad performance to choose a pivot
3470 : ! and apply the general algorithm.
3471 : !
3472 : Case (2)
3473 0 : If (XDONT(IHIGT(1)) <= XDONT(IHIGT(2))) Then
3474 0 : JLOW = JLOW + 1
3475 0 : ILOWT (JLOW) = IHIGT (1)
3476 0 : JLOW = JLOW + 1
3477 0 : ILOWT (JLOW) = IHIGT (2)
3478 : Else
3479 0 : JLOW = JLOW + 1
3480 0 : ILOWT (JLOW) = IHIGT (2)
3481 0 : JLOW = JLOW + 1
3482 0 : ILOWT (JLOW) = IHIGT (1)
3483 : End If
3484 : Exit
3485 : !
3486 : Case (3)
3487 : !
3488 : !
3489 0 : IWRK1 = IHIGT (1)
3490 0 : IWRK2 = IHIGT (2)
3491 0 : IWRK3 = IHIGT (3)
3492 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
3493 0 : IHIGT (1) = IWRK2
3494 0 : IHIGT (2) = IWRK1
3495 0 : IWRK2 = IWRK1
3496 : End If
3497 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
3498 0 : IHIGT (3) = IWRK2
3499 0 : IHIGT (2) = IWRK3
3500 0 : IWRK2 = IWRK3
3501 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
3502 0 : IHIGT (2) = IHIGT (1)
3503 0 : IHIGT (1) = IWRK2
3504 : End If
3505 : End If
3506 : JHIG = 0
3507 0 : Do ICRS = JLOW + 1, INTH
3508 0 : JHIG = JHIG + 1
3509 0 : ILOWT (ICRS) = IHIGT (JHIG)
3510 : End Do
3511 0 : JLOW = INTH
3512 : Exit
3513 : !
3514 : Case (4 :)
3515 : !
3516 : !
3517 0 : IFIN = JHIG
3518 : !
3519 : ! One chooses a pivot from the 2 first values and the last one.
3520 : ! This should ensure sufficient renewal between iterations to
3521 : ! avoid worst case behavior effects.
3522 : !
3523 0 : IWRK1 = IHIGT (1)
3524 0 : IWRK2 = IHIGT (2)
3525 0 : IWRK3 = IHIGT (IFIN)
3526 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
3527 0 : IHIGT (1) = IWRK2
3528 0 : IHIGT (2) = IWRK1
3529 0 : IWRK2 = IWRK1
3530 : End If
3531 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
3532 0 : IHIGT (IFIN) = IWRK2
3533 0 : IHIGT (2) = IWRK3
3534 0 : IWRK2 = IWRK3
3535 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
3536 0 : IHIGT (2) = IHIGT (1)
3537 0 : IHIGT (1) = IWRK2
3538 : End If
3539 : End If
3540 : !
3541 0 : IWRK1 = IHIGT (1)
3542 0 : JLOW = JLOW + 1
3543 0 : ILOWT (JLOW) = IWRK1
3544 0 : XPIV = XDONT (IWRK1) + (XDONT(IHIGT(IFIN)) - XDONT(IWRK1)) / 2
3545 : !
3546 : ! One takes values <= pivot to ILOWT
3547 : ! Again, 2 parts, one where we take care of the remaining
3548 : ! high values because we might still need them, and the
3549 : ! other when we know that we will have more than enough
3550 : ! low values in the end.
3551 : !
3552 0 : JHIG = 0
3553 0 : Do ICRS = 2, IFIN
3554 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
3555 0 : JLOW = JLOW + 1
3556 0 : ILOWT (JLOW) = IHIGT (ICRS)
3557 0 : If (JLOW >= INTH) Exit
3558 : Else
3559 0 : JHIG = JHIG + 1
3560 0 : IHIGT (JHIG) = IHIGT (ICRS)
3561 : End If
3562 : End Do
3563 : !
3564 0 : Do ICRS = ICRS + 1, IFIN
3565 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
3566 0 : JLOW = JLOW + 1
3567 0 : ILOWT (JLOW) = IHIGT (ICRS)
3568 : End If
3569 : End Do
3570 : End Select
3571 : !
3572 : !
3573 : Case (1)
3574 : !
3575 : ! Only 1 value is missing in low part
3576 : !
3577 0 : XMIN = XDONT (IHIGT(1))
3578 0 : IHIG = 1
3579 0 : Do ICRS = 2, JHIG
3580 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
3581 0 : XMIN = XDONT (IHIGT(ICRS))
3582 0 : IHIG = ICRS
3583 : End If
3584 : End Do
3585 : !
3586 0 : INDNTH = IHIGT (IHIG)
3587 0 : Return
3588 : !
3589 : !
3590 : Case (0)
3591 : !
3592 : ! Low part is exactly what we want
3593 : !
3594 0 : Exit
3595 : !
3596 : !
3597 : Case (-5 : -1)
3598 : !
3599 : ! Only few values too many in low part
3600 : !
3601 0 : IRNGT (1) = ILOWT (1)
3602 0 : ILOW = 1 + INTH - JLOW
3603 0 : Do ICRS = 2, INTH
3604 0 : IWRK = ILOWT (ICRS)
3605 0 : XWRK = XDONT (IWRK)
3606 0 : Do IDCR = ICRS - 1, MAX (1, ILOW), - 1
3607 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
3608 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
3609 : Else
3610 : Exit
3611 : End If
3612 : End Do
3613 0 : IRNGT (IDCR + 1) = IWRK
3614 0 : ILOW = ILOW + 1
3615 : End Do
3616 : !
3617 0 : XWRK1 = XDONT (IRNGT(INTH))
3618 0 : ILOW = 2 * INTH - JLOW
3619 0 : Do ICRS = INTH + 1, JLOW
3620 0 : If (XDONT(ILOWT (ICRS)) < XWRK1) Then
3621 0 : XWRK = XDONT (ILOWT (ICRS))
3622 0 : Do IDCR = INTH - 1, MAX (1, ILOW), - 1
3623 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
3624 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
3625 : End Do
3626 0 : IRNGT (IDCR + 1) = ILOWT (ICRS)
3627 0 : XWRK1 = XDONT (IRNGT(INTH))
3628 : End If
3629 0 : ILOW = ILOW + 1
3630 : End Do
3631 : !
3632 0 : INDNTH = IRNGT(INTH)
3633 0 : Return
3634 : !
3635 : !
3636 : Case (: -6)
3637 : !
3638 : ! last case: too many values in low part
3639 : !
3640 :
3641 0 : IMIL = (JLOW + 1) / 2
3642 0 : IFIN = JLOW
3643 : !
3644 : ! One chooses a pivot from 1st, last, and middle values
3645 : !
3646 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(1))) Then
3647 0 : IWRK = ILOWT (1)
3648 0 : ILOWT (1) = ILOWT (IMIL)
3649 0 : ILOWT (IMIL) = IWRK
3650 : End If
3651 0 : If (XDONT(ILOWT(IMIL)) > XDONT(ILOWT(IFIN))) Then
3652 0 : IWRK = ILOWT (IFIN)
3653 0 : ILOWT (IFIN) = ILOWT (IMIL)
3654 0 : ILOWT (IMIL) = IWRK
3655 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(1))) Then
3656 0 : IWRK = ILOWT (1)
3657 0 : ILOWT (1) = ILOWT (IMIL)
3658 0 : ILOWT (IMIL) = IWRK
3659 : End If
3660 : End If
3661 0 : If (IFIN <= 3) Exit
3662 : !
3663 0 : XPIV = XDONT (ILOWT(1)) + INT(REAL(INTH, sp) / REAL(JLOW + INTH, sp), i4) * &
3664 0 : (XDONT(ILOWT(IFIN)) - XDONT(ILOWT(1)))
3665 :
3666 : !
3667 : ! One takes values > XPIV to IHIGT
3668 : !
3669 0 : JHIG = 0
3670 0 : JLOW = 0
3671 : !
3672 0 : If (XDONT(ILOWT(IFIN)) > XPIV) Then
3673 : ICRS = 0
3674 : Do
3675 0 : ICRS = ICRS + 1
3676 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
3677 0 : JHIG = JHIG + 1
3678 0 : IHIGT (JHIG) = ILOWT (ICRS)
3679 0 : If (ICRS >= IFIN) Exit
3680 : Else
3681 0 : JLOW = JLOW + 1
3682 0 : ILOWT (JLOW) = ILOWT (ICRS)
3683 0 : If (JLOW >= INTH) Exit
3684 : End If
3685 : End Do
3686 : !
3687 0 : If (ICRS < IFIN) Then
3688 : Do
3689 0 : ICRS = ICRS + 1
3690 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
3691 0 : JLOW = JLOW + 1
3692 0 : ILOWT (JLOW) = ILOWT (ICRS)
3693 : Else
3694 0 : If (ICRS >= IFIN) Exit
3695 : End If
3696 : End Do
3697 : End If
3698 : Else
3699 0 : Do ICRS = 1, IFIN
3700 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
3701 0 : JHIG = JHIG + 1
3702 0 : IHIGT (JHIG) = ILOWT (ICRS)
3703 : Else
3704 0 : JLOW = JLOW + 1
3705 0 : ILOWT (JLOW) = ILOWT (ICRS)
3706 0 : If (JLOW >= INTH) Exit
3707 : End If
3708 : End Do
3709 : !
3710 0 : Do ICRS = ICRS + 1, IFIN
3711 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
3712 0 : JLOW = JLOW + 1
3713 0 : ILOWT (JLOW) = ILOWT (ICRS)
3714 : End If
3715 : End Do
3716 : End If
3717 : !
3718 : End Select
3719 : !
3720 : End Do
3721 : !
3722 : ! Now, we only need to find maximum of the 1:INTH set
3723 : !
3724 :
3725 0 : IWRK1 = ILOWT (1)
3726 0 : XWRK1 = XDONT (IWRK1)
3727 0 : Do ICRS = 1 + 1, INTH
3728 0 : IWRK = ILOWT (ICRS)
3729 0 : XWRK = XDONT (IWRK)
3730 0 : If (XWRK > XWRK1) Then
3731 0 : XWRK1 = XWRK
3732 0 : IWRK1 = IWRK
3733 : End If
3734 : End Do
3735 0 : INDNTH = IWRK1
3736 : Return
3737 : !
3738 : !
3739 0 : End Function I_indnth
3740 :
3741 0 : Subroutine D_inspar (XDONT, NORD)
3742 : ! Sorts partially XDONT, bringing the NORD lowest values at the
3743 : ! begining of the array
3744 : ! __________________________________________________________
3745 : ! This subroutine uses insertion sort, limiting insertion
3746 : ! to the first NORD values. It does not use any work array
3747 : ! and is faster when NORD is very small (2-5), but worst case
3748 : ! behavior can happen fairly probably (initially inverse sorted)
3749 : ! In many cases, the refined quicksort method is faster.
3750 : ! Michel Olagnon - Feb. 2000
3751 : ! __________________________________________________________
3752 : ! __________________________________________________________
3753 : real(kind = dp), Dimension (:), Intent (InOut) :: XDONT
3754 : Integer(kind = i4), Intent (In) :: NORD
3755 : ! __________________________________________________________
3756 0 : real(kind = dp) :: XWRK, XWRK1
3757 : !
3758 : Integer(kind = i4) :: ICRS, IDCR
3759 : !
3760 0 : Do ICRS = 2, NORD
3761 0 : XWRK = XDONT (ICRS)
3762 0 : Do IDCR = ICRS - 1, 1, - 1
3763 0 : If (XWRK >= XDONT(IDCR)) Exit
3764 0 : XDONT (IDCR + 1) = XDONT (IDCR)
3765 : End Do
3766 0 : XDONT (IDCR + 1) = XWRK
3767 : End Do
3768 : !
3769 0 : XWRK1 = XDONT (NORD)
3770 0 : Do ICRS = NORD + 1, SIZE (XDONT)
3771 0 : If (XDONT(ICRS) < XWRK1) Then
3772 0 : XWRK = XDONT (ICRS)
3773 0 : XDONT (ICRS) = XWRK1
3774 0 : Do IDCR = NORD - 1, 1, - 1
3775 0 : If (XWRK >= XDONT(IDCR)) Exit
3776 0 : XDONT (IDCR + 1) = XDONT (IDCR)
3777 : End Do
3778 0 : XDONT (IDCR + 1) = XWRK
3779 0 : XWRK1 = XDONT (NORD)
3780 : End If
3781 : End Do
3782 : !
3783 : !
3784 0 : End Subroutine D_inspar
3785 :
3786 0 : Subroutine R_inspar (XDONT, NORD)
3787 : ! Sorts partially XDONT, bringing the NORD lowest values at the
3788 : ! begining of the array
3789 : ! __________________________________________________________
3790 : ! This subroutine uses insertion sort, limiting insertion
3791 : ! to the first NORD values. It does not use any work array
3792 : ! and is faster when NORD is very small (2-5), but worst case
3793 : ! behavior can happen fairly probably (initially inverse sorted)
3794 : ! In many cases, the refined quicksort method is faster.
3795 : ! Michel Olagnon - Feb. 2000
3796 : ! __________________________________________________________
3797 : ! _________________________________________________________
3798 : Real(kind = sp), Dimension (:), Intent (InOut) :: XDONT
3799 : Integer(kind = i4), Intent (In) :: NORD
3800 : ! __________________________________________________________
3801 0 : Real(kind = sp) :: XWRK, XWRK1
3802 : !
3803 : Integer(kind = i4) :: ICRS, IDCR
3804 : !
3805 0 : Do ICRS = 2, NORD
3806 0 : XWRK = XDONT (ICRS)
3807 0 : Do IDCR = ICRS - 1, 1, - 1
3808 0 : If (XWRK >= XDONT(IDCR)) Exit
3809 0 : XDONT (IDCR + 1) = XDONT (IDCR)
3810 : End Do
3811 0 : XDONT (IDCR + 1) = XWRK
3812 : End Do
3813 : !
3814 0 : XWRK1 = XDONT (NORD)
3815 0 : Do ICRS = NORD + 1, SIZE (XDONT)
3816 0 : If (XDONT(ICRS) < XWRK1) Then
3817 0 : XWRK = XDONT (ICRS)
3818 0 : XDONT (ICRS) = XWRK1
3819 0 : Do IDCR = NORD - 1, 1, - 1
3820 0 : If (XWRK >= XDONT(IDCR)) Exit
3821 0 : XDONT (IDCR + 1) = XDONT (IDCR)
3822 : End Do
3823 0 : XDONT (IDCR + 1) = XWRK
3824 0 : XWRK1 = XDONT (NORD)
3825 : End If
3826 : End Do
3827 : !
3828 : !
3829 0 : End Subroutine R_inspar
3830 :
3831 0 : Subroutine I_inspar (XDONT, NORD)
3832 : ! Sorts partially XDONT, bringing the NORD lowest values at the
3833 : ! begining of the array
3834 : ! __________________________________________________________
3835 : ! This subroutine uses insertion sort, limiting insertion
3836 : ! to the first NORD values. It does not use any work array
3837 : ! and is faster when NORD is very small (2-5), but worst case
3838 : ! behavior can happen fairly probably (initially inverse sorted)
3839 : ! In many cases, the refined quicksort method is faster.
3840 : ! Michel Olagnon - Feb. 2000
3841 : ! __________________________________________________________
3842 : ! __________________________________________________________
3843 : Integer(kind = i4), Dimension (:), Intent (InOut) :: XDONT
3844 : Integer(kind = i4), Intent (In) :: NORD
3845 : ! __________________________________________________________
3846 : Integer(kind = i4) :: XWRK, XWRK1
3847 : !
3848 : Integer(kind = i4) :: ICRS, IDCR
3849 : !
3850 0 : Do ICRS = 2, NORD
3851 0 : XWRK = XDONT (ICRS)
3852 0 : Do IDCR = ICRS - 1, 1, - 1
3853 0 : If (XWRK >= XDONT(IDCR)) Exit
3854 0 : XDONT (IDCR + 1) = XDONT (IDCR)
3855 : End Do
3856 0 : XDONT (IDCR + 1) = XWRK
3857 : End Do
3858 : !
3859 0 : XWRK1 = XDONT (NORD)
3860 0 : Do ICRS = NORD + 1, SIZE (XDONT)
3861 0 : If (XDONT(ICRS) < XWRK1) Then
3862 0 : XWRK = XDONT (ICRS)
3863 0 : XDONT (ICRS) = XWRK1
3864 0 : Do IDCR = NORD - 1, 1, - 1
3865 0 : If (XWRK >= XDONT(IDCR)) Exit
3866 0 : XDONT (IDCR + 1) = XDONT (IDCR)
3867 : End Do
3868 0 : XDONT (IDCR + 1) = XWRK
3869 0 : XWRK1 = XDONT (NORD)
3870 : End If
3871 : End Do
3872 : !
3873 : !
3874 0 : End Subroutine I_inspar
3875 :
3876 4 : Subroutine D_inssor (XDONT)
3877 : ! Sorts XDONT into increasing order (Insertion sort)
3878 : ! __________________________________________________________
3879 : ! This subroutine uses insertion sort. It does not use any
3880 : ! work array and is faster when XDONT is of very small size
3881 : ! (< 20), or already almost sorted, but worst case behavior
3882 : ! can happen fairly probably (initially inverse sorted).
3883 : ! In many cases, the quicksort or merge sort method is faster.
3884 : ! Michel Olagnon - Apr. 2000
3885 : ! __________________________________________________________
3886 : ! __________________________________________________________
3887 : ! __________________________________________________________
3888 : real(kind = dp), Dimension (:), Intent (InOut) :: XDONT
3889 : ! __________________________________________________________
3890 4 : real(Kind = dp) :: XWRK, XMIN
3891 : !
3892 : ! __________________________________________________________
3893 : !
3894 : Integer(kind = i4) :: ICRS, IDCR, NDON
3895 : !
3896 4 : NDON = Size (XDONT)
3897 : !
3898 : ! We first bring the minimum to the first location in the array.
3899 : ! That way, we will have a "guard", and when looking for the
3900 : ! right place to insert a value, no loop test is necessary.
3901 : !
3902 4 : If (XDONT (1) < XDONT (NDON)) Then
3903 : XMIN = XDONT (1)
3904 : Else
3905 2 : XMIN = XDONT (NDON)
3906 2 : XDONT (NDON) = XDONT (1)
3907 : end if
3908 152 : Do IDCR = NDON - 1, 2, -1
3909 148 : XWRK = XDONT(IDCR)
3910 152 : IF (XWRK < XMIN) Then
3911 0 : XDONT (IDCR) = XMIN
3912 0 : XMIN = XWRK
3913 : End If
3914 : End Do
3915 4 : XDONT (1) = XMIN
3916 : !
3917 : ! The first value is now the minimum
3918 : ! Loop over the array, and when a value is smaller than
3919 : ! the previous one, loop down to insert it at its right place.
3920 : !
3921 152 : Do ICRS = 3, NDON
3922 148 : XWRK = XDONT (ICRS)
3923 148 : IDCR = ICRS - 1
3924 152 : If (XWRK < XDONT(IDCR)) Then
3925 108 : XDONT (ICRS) = XDONT (IDCR)
3926 108 : IDCR = IDCR - 1
3927 311 : Do
3928 419 : If (XWRK >= XDONT(IDCR)) Exit
3929 311 : XDONT (IDCR + 1) = XDONT (IDCR)
3930 311 : IDCR = IDCR - 1
3931 : End Do
3932 108 : XDONT (IDCR + 1) = XWRK
3933 : End If
3934 : End Do
3935 : !
3936 4 : Return
3937 : !
3938 0 : End Subroutine D_inssor
3939 :
3940 2 : Subroutine R_inssor (XDONT)
3941 : ! Sorts XDONT into increasing order (Insertion sort)
3942 : ! __________________________________________________________
3943 : ! This subroutine uses insertion sort. It does not use any
3944 : ! work array and is faster when XDONT is of very small size
3945 : ! (< 20), or already almost sorted, but worst case behavior
3946 : ! can happen fairly probably (initially inverse sorted).
3947 : ! In many cases, the quicksort or merge sort method is faster.
3948 : ! Michel Olagnon - Apr. 2000
3949 : ! __________________________________________________________
3950 : ! __________________________________________________________
3951 : ! _________________________________________________________
3952 : Real(kind = sp), Dimension (:), Intent (InOut) :: XDONT
3953 : ! __________________________________________________________
3954 2 : Real(kind = sp) :: XWRK, XMIN
3955 : !
3956 : ! __________________________________________________________
3957 : !
3958 : Integer(kind = i4) :: ICRS, IDCR, NDON
3959 : !
3960 2 : NDON = Size (XDONT)
3961 : !
3962 : ! We first bring the minimum to the first location in the array.
3963 : ! That way, we will have a "guard", and when looking for the
3964 : ! right place to insert a value, no loop test is necessary.
3965 : !
3966 2 : If (XDONT (1) < XDONT (NDON)) Then
3967 : XMIN = XDONT (1)
3968 : Else
3969 2 : XMIN = XDONT (NDON)
3970 2 : XDONT (NDON) = XDONT (1)
3971 : end if
3972 18 : Do IDCR = NDON - 1, 2, -1
3973 16 : XWRK = XDONT(IDCR)
3974 18 : IF (XWRK < XMIN) Then
3975 0 : XDONT (IDCR) = XMIN
3976 0 : XMIN = XWRK
3977 : End If
3978 : End Do
3979 2 : XDONT (1) = XMIN
3980 : !
3981 : ! The first value is now the minimum
3982 : ! Loop over the array, and when a value is smaller than
3983 : ! the previous one, loop down to insert it at its right place.
3984 : !
3985 18 : Do ICRS = 3, NDON
3986 16 : XWRK = XDONT (ICRS)
3987 16 : IDCR = ICRS - 1
3988 18 : If (XWRK < XDONT(IDCR)) Then
3989 14 : XDONT (ICRS) = XDONT (IDCR)
3990 14 : IDCR = IDCR - 1
3991 42 : Do
3992 56 : If (XWRK >= XDONT(IDCR)) Exit
3993 42 : XDONT (IDCR + 1) = XDONT (IDCR)
3994 42 : IDCR = IDCR - 1
3995 : End Do
3996 14 : XDONT (IDCR + 1) = XWRK
3997 : End If
3998 : End Do
3999 : !
4000 2 : Return
4001 : !
4002 4 : End Subroutine R_inssor
4003 :
4004 4452 : Subroutine I_inssor (XDONT)
4005 : ! Sorts XDONT into increasing order (Insertion sort)
4006 : ! __________________________________________________________
4007 : ! This subroutine uses insertion sort. It does not use any
4008 : ! work array and is faster when XDONT is of very small size
4009 : ! (< 20), or already almost sorted, but worst case behavior
4010 : ! can happen fairly probably (initially inverse sorted).
4011 : ! In many cases, the quicksort or merge sort method is faster.
4012 : ! Michel Olagnon - Apr. 2000
4013 : ! __________________________________________________________
4014 : ! __________________________________________________________
4015 : ! __________________________________________________________
4016 : Integer(kind = i4), Dimension (:), Intent (InOut) :: XDONT
4017 : ! __________________________________________________________
4018 : Integer(kind = i4) :: XWRK, XMIN
4019 : !
4020 : ! __________________________________________________________
4021 : !
4022 : Integer(kind = i4) :: ICRS, IDCR, NDON
4023 : !
4024 4452 : NDON = Size (XDONT)
4025 : !
4026 : ! We first bring the minimum to the first location in the array.
4027 : ! That way, we will have a "guard", and when looking for the
4028 : ! right place to insert a value, no loop test is necessary.
4029 : !
4030 4452 : If (XDONT (1) < XDONT (NDON)) Then
4031 : XMIN = XDONT (1)
4032 : Else
4033 68 : XMIN = XDONT (NDON)
4034 68 : XDONT (NDON) = XDONT (1)
4035 : end if
4036 128646 : Do IDCR = NDON - 1, 2, -1
4037 124194 : XWRK = XDONT(IDCR)
4038 128646 : IF (XWRK < XMIN) Then
4039 7697 : XDONT (IDCR) = XMIN
4040 7697 : XMIN = XWRK
4041 : End If
4042 : End Do
4043 4452 : XDONT (1) = XMIN
4044 : !
4045 : ! The first value is now the minimum
4046 : ! Loop over the array, and when a value is smaller than
4047 : ! the previous one, loop down to insert it at its right place.
4048 : !
4049 128646 : Do ICRS = 3, NDON
4050 124194 : XWRK = XDONT (ICRS)
4051 124194 : IDCR = ICRS - 1
4052 128646 : If (XWRK < XDONT(IDCR)) Then
4053 88613 : XDONT (ICRS) = XDONT (IDCR)
4054 88613 : IDCR = IDCR - 1
4055 228094 : Do
4056 316707 : If (XWRK >= XDONT(IDCR)) Exit
4057 228094 : XDONT (IDCR + 1) = XDONT (IDCR)
4058 228094 : IDCR = IDCR - 1
4059 : End Do
4060 88613 : XDONT (IDCR + 1) = XWRK
4061 : End If
4062 : End Do
4063 : !
4064 4452 : Return
4065 : !
4066 2 : End Subroutine I_inssor
4067 :
4068 0 : Subroutine C_inssor (XDONT)
4069 : ! Sorts XDONT into increasing order (Insertion sort)
4070 : ! __________________________________________________________
4071 : ! This subroutine uses insertion sort. It does not use any
4072 : ! work array and is faster when XDONT is of very small size
4073 : ! (< 20), or already almost sorted, but worst case behavior
4074 : ! can happen fairly probably (initially inverse sorted).
4075 : ! In many cases, the quicksort or merge sort method is faster.
4076 : ! Michel Olagnon - Apr. 2000
4077 : ! __________________________________________________________
4078 : ! __________________________________________________________
4079 : ! __________________________________________________________
4080 : character(*), Dimension (:), Intent (InOut) :: XDONT
4081 : ! __________________________________________________________
4082 0 : character(len(XDONT)) :: XWRK, XMIN
4083 : !
4084 : ! __________________________________________________________
4085 : !
4086 : Integer(kind = i4) :: ICRS, IDCR, NDON
4087 : !
4088 0 : NDON = Size (XDONT)
4089 : !
4090 : ! We first bring the minimum to the first location in the array.
4091 : ! That way, we will have a "guard", and when looking for the
4092 : ! right place to insert a value, no loop test is necessary.
4093 : !
4094 0 : If (XDONT (1) < XDONT (NDON)) Then
4095 0 : XMIN = XDONT (1)
4096 : Else
4097 0 : XMIN = XDONT (NDON)
4098 0 : XDONT (NDON) = XDONT (1)
4099 : end if
4100 0 : Do IDCR = NDON - 1, 2, -1
4101 0 : XWRK = XDONT(IDCR)
4102 0 : IF (XWRK < XMIN) Then
4103 0 : XDONT (IDCR) = XMIN
4104 0 : XMIN = XWRK
4105 : End If
4106 : End Do
4107 0 : XDONT (1) = XMIN
4108 : !
4109 : ! The first value is now the minimum
4110 : ! Loop over the array, and when a value is smaller than
4111 : ! the previous one, loop down to insert it at its right place.
4112 : !
4113 0 : Do ICRS = 3, NDON
4114 0 : XWRK = XDONT (ICRS)
4115 0 : IDCR = ICRS - 1
4116 0 : If (XWRK < XDONT(IDCR)) Then
4117 0 : XDONT (ICRS) = XDONT (IDCR)
4118 0 : IDCR = IDCR - 1
4119 0 : Do
4120 0 : If (XWRK >= XDONT(IDCR)) Exit
4121 0 : XDONT (IDCR + 1) = XDONT (IDCR)
4122 0 : IDCR = IDCR - 1
4123 : End Do
4124 0 : XDONT (IDCR + 1) = XWRK
4125 : End If
4126 : End Do
4127 : !
4128 0 : Return
4129 : !
4130 4452 : End Subroutine C_inssor
4131 :
4132 1 : Function D_median (XDONT) Result (median)
4133 : ! Return median value of XDONT
4134 : ! If even number of data, average of the two "medians".
4135 : ! __________________________________________________________
4136 : ! This routine uses a pivoting strategy such as the one of
4137 : ! finding the median based on the quicksort algorithm, but
4138 : ! we skew the pivot choice to try to bring it to NORD as
4139 : ! fast as possible. It uses 2 temporary arrays, where it
4140 : ! stores the indices of the values smaller than the pivot
4141 : ! (ILOWT), and the indices of values larger than the pivot
4142 : ! that we might still need later on (IHIGT). It iterates
4143 : ! until it can bring the number of values in ILOWT to
4144 : ! exactly NORD, and then finds the maximum of this set.
4145 : ! Michel Olagnon - Aug. 2000
4146 : ! __________________________________________________________
4147 : ! __________________________________________________________
4148 : real(Kind = dp), Dimension (:), Intent (In) :: XDONT
4149 : real(Kind = dp) :: median
4150 : ! __________________________________________________________
4151 22 : real(Kind = dp), Dimension (SIZE(XDONT)) :: XLOWT, XHIGT
4152 1 : real(Kind = dp) :: XPIV, XWRK, XWRK1, XWRK2, XWRK3, XMIN, XMAX
4153 : !!
4154 : Logical :: IFODD
4155 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG!, NORD
4156 : Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR!, ILOW
4157 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
4158 : !
4159 1 : NDON = SIZE (XDONT)
4160 1 : INTH = NDON / 2 + 1
4161 1 : IFODD = (2 * INTH == NDON + 1)
4162 : !
4163 : ! First loop is used to fill-in XLOWT, XHIGT at the same time
4164 : !
4165 1 : If (NDON < 3) Then
4166 0 : If (NDON > 0) median = 0.5 * (XDONT (1) + XDONT (NDON))
4167 0 : Return
4168 : End If
4169 : !
4170 : ! One chooses a pivot, best estimate possible to put fractile near
4171 : ! mid-point of the set of low values.
4172 : !
4173 1 : If (XDONT(2) < XDONT(1)) Then
4174 0 : XLOWT (1) = XDONT(2)
4175 0 : XHIGT (1) = XDONT(1)
4176 : Else
4177 1 : XLOWT (1) = XDONT(1)
4178 1 : XHIGT (1) = XDONT(2)
4179 : End If
4180 : !
4181 : !
4182 1 : If (XDONT(3) < XHIGT(1)) Then
4183 0 : XHIGT (2) = XHIGT (1)
4184 0 : If (XDONT(3) < XLOWT(1)) Then
4185 0 : XHIGT (1) = XLOWT (1)
4186 0 : XLOWT (1) = XDONT(3)
4187 : Else
4188 0 : XHIGT (1) = XDONT(3)
4189 : End If
4190 : Else
4191 1 : XHIGT (2) = XDONT(3)
4192 : End If
4193 : !
4194 1 : If (NDON < 4) Then ! 3 values
4195 0 : median = XHIGT (1)
4196 0 : Return
4197 : End If
4198 : !
4199 1 : If (XDONT(NDON) < XHIGT(1)) Then
4200 0 : XHIGT (3) = XHIGT (2)
4201 0 : XHIGT (2) = XHIGT (1)
4202 0 : If (XDONT(NDON) < XLOWT(1)) Then
4203 0 : XHIGT (1) = XLOWT (1)
4204 0 : XLOWT (1) = XDONT(NDON)
4205 : Else
4206 0 : XHIGT (1) = XDONT(NDON)
4207 : End If
4208 : Else
4209 1 : If (XDONT(NDON) < XHIGT(2)) Then
4210 0 : XHIGT (3) = XHIGT (2)
4211 0 : XHIGT (2) = XDONT(NDON)
4212 : Else
4213 1 : XHIGT (3) = XDONT(NDON)
4214 : End If
4215 : End If
4216 : !
4217 1 : If (NDON < 5) Then ! 4 values
4218 0 : median = 0.5 * (XHIGT (1) + XHIGT (2))
4219 0 : Return
4220 : End If
4221 : !
4222 1 : JLOW = 1
4223 1 : JHIG = 3
4224 1 : XPIV = XLOWT(1) + 2.0 * (XHIGT(3) - XLOWT(1)) / 3.0
4225 1 : If (XPIV >= XHIGT(1)) Then
4226 1 : XPIV = XLOWT(1) + 2.0 * (XHIGT(2) - XLOWT(1)) / 3.0
4227 1 : If (XPIV >= XHIGT(1)) XPIV = XLOWT(1) + 2.0 * (XHIGT(1) - XLOWT(1)) / 3.0
4228 : End If
4229 : !
4230 : ! One puts values > pivot in the end and those <= pivot
4231 : ! at the beginning. This is split in 2 cases, so that
4232 : ! we can skip the loop test a number of times.
4233 : ! As we are also filling in the work arrays at the same time
4234 : ! we stop filling in the XHIGT array as soon as we have more
4235 : ! than enough values in XLOWT.
4236 : !
4237 : !
4238 1 : If (XDONT(NDON) > XPIV) Then
4239 : ICRS = 3
4240 : Do
4241 7 : ICRS = ICRS + 1
4242 8 : If (XDONT(ICRS) > XPIV) Then
4243 7 : If (ICRS >= NDON) Exit
4244 6 : JHIG = JHIG + 1
4245 6 : XHIGT (JHIG) = XDONT(ICRS)
4246 : Else
4247 0 : JLOW = JLOW + 1
4248 0 : XLOWT (JLOW) = XDONT(ICRS)
4249 0 : If (JLOW >= INTH) Exit
4250 : End If
4251 : End Do
4252 : !
4253 : ! One restricts further processing because it is no use
4254 : ! to store more high values
4255 : !
4256 1 : If (ICRS < NDON - 1) Then
4257 : Do
4258 0 : ICRS = ICRS + 1
4259 0 : If (XDONT(ICRS) <= XPIV) Then
4260 0 : JLOW = JLOW + 1
4261 0 : XLOWT (JLOW) = XDONT(ICRS)
4262 0 : Else If (ICRS >= NDON) Then
4263 : Exit
4264 : End If
4265 : End Do
4266 : End If
4267 : !
4268 : !
4269 : Else
4270 : !
4271 : ! Same as above, but this is not as easy to optimize, so the
4272 : ! DO-loop is kept
4273 : !
4274 0 : Do ICRS = 4, NDON - 1
4275 0 : If (XDONT(ICRS) > XPIV) Then
4276 0 : JHIG = JHIG + 1
4277 0 : XHIGT (JHIG) = XDONT(ICRS)
4278 : Else
4279 0 : JLOW = JLOW + 1
4280 0 : XLOWT (JLOW) = XDONT(ICRS)
4281 0 : If (JLOW >= INTH) Exit
4282 : End If
4283 : End Do
4284 : !
4285 0 : If (ICRS < NDON - 1) Then
4286 : Do
4287 0 : ICRS = ICRS + 1
4288 0 : If (XDONT(ICRS) <= XPIV) Then
4289 0 : If (ICRS >= NDON) Exit
4290 0 : JLOW = JLOW + 1
4291 0 : XLOWT (JLOW) = XDONT(ICRS)
4292 : End If
4293 : End Do
4294 : End If
4295 : End If
4296 : !
4297 : JLM2 = 0
4298 : JLM1 = 0
4299 : JHM2 = 0
4300 : JHM1 = 0
4301 : Do
4302 2 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
4303 : !
4304 : ! We are oscillating. Perturbate by bringing JLOW closer by one
4305 : ! to INTH
4306 : !
4307 0 : If (INTH > JLOW) Then
4308 0 : XMIN = XHIGT(1)
4309 0 : IHIG = 1
4310 0 : Do ICRS = 2, JHIG
4311 0 : If (XHIGT(ICRS) < XMIN) Then
4312 0 : XMIN = XHIGT(ICRS)
4313 0 : IHIG = ICRS
4314 : End If
4315 : End Do
4316 : !
4317 0 : JLOW = JLOW + 1
4318 0 : XLOWT (JLOW) = XHIGT (IHIG)
4319 0 : XHIGT (IHIG) = XHIGT (JHIG)
4320 0 : JHIG = JHIG - 1
4321 : Else
4322 :
4323 0 : XMAX = XLOWT (JLOW)
4324 0 : JLOW = JLOW - 1
4325 0 : Do ICRS = 1, JLOW
4326 0 : If (XLOWT(ICRS) > XMAX) Then
4327 0 : XWRK = XMAX
4328 0 : XMAX = XLOWT(ICRS)
4329 0 : XLOWT (ICRS) = XWRK
4330 : End If
4331 : End Do
4332 : End If
4333 : End If
4334 2 : JLM2 = JLM1
4335 2 : JLM1 = JLOW
4336 2 : JHM2 = JHM1
4337 2 : JHM1 = JHIG
4338 : !
4339 : ! We try to bring the number of values in the low values set
4340 : ! closer to INTH.
4341 : !
4342 3 : Select Case (INTH - JLOW)
4343 : Case (2 :)
4344 : !
4345 : ! Not enough values in low part, at least 2 are missing
4346 : !
4347 1 : INTH = INTH - JLOW
4348 1 : JLOW = 0
4349 : Select Case (JHIG)
4350 : !!!!! CASE DEFAULT
4351 : !!!!! write (unit=*,fmt=*) "Assertion failed"
4352 : !!!!! STOP
4353 : !
4354 : ! We make a special case when we have so few values in
4355 : ! the high values set that it is bad performance to choose a pivot
4356 : ! and apply the general algorithm.
4357 : !
4358 : Case (2)
4359 0 : If (XHIGT(1) <= XHIGT(2)) Then
4360 0 : JLOW = JLOW + 1
4361 0 : XLOWT (JLOW) = XHIGT (1)
4362 0 : JLOW = JLOW + 1
4363 0 : XLOWT (JLOW) = XHIGT (2)
4364 : Else
4365 0 : JLOW = JLOW + 1
4366 0 : XLOWT (JLOW) = XHIGT (2)
4367 0 : JLOW = JLOW + 1
4368 0 : XLOWT (JLOW) = XHIGT (1)
4369 : End If
4370 : Exit
4371 : !
4372 : Case (3)
4373 : !
4374 : !
4375 0 : XWRK1 = XHIGT (1)
4376 0 : XWRK2 = XHIGT (2)
4377 0 : XWRK3 = XHIGT (3)
4378 0 : If (XWRK2 < XWRK1) Then
4379 0 : XHIGT (1) = XWRK2
4380 0 : XHIGT (2) = XWRK1
4381 0 : XWRK2 = XWRK1
4382 : End If
4383 0 : If (XWRK2 > XWRK3) Then
4384 0 : XHIGT (3) = XWRK2
4385 0 : XHIGT (2) = XWRK3
4386 0 : XWRK2 = XWRK3
4387 0 : If (XWRK2 < XHIGT(1)) Then
4388 0 : XHIGT (2) = XHIGT (1)
4389 0 : XHIGT (1) = XWRK2
4390 : End If
4391 : End If
4392 : JHIG = 0
4393 0 : Do ICRS = JLOW + 1, INTH
4394 0 : JHIG = JHIG + 1
4395 0 : XLOWT (ICRS) = XHIGT (JHIG)
4396 : End Do
4397 1 : JLOW = INTH
4398 : Exit
4399 : !
4400 : Case (4 :)
4401 : !
4402 : !
4403 1 : IFIN = JHIG
4404 : !
4405 : ! One chooses a pivot from the 2 first values and the last one.
4406 : ! This should ensure sufficient renewal between iterations to
4407 : ! avoid worst case behavior effects.
4408 : !
4409 1 : XWRK1 = XHIGT (1)
4410 1 : XWRK2 = XHIGT (2)
4411 1 : XWRK3 = XHIGT (IFIN)
4412 1 : If (XWRK2 < XWRK1) Then
4413 0 : XHIGT (1) = XWRK2
4414 0 : XHIGT (2) = XWRK1
4415 0 : XWRK2 = XWRK1
4416 : End If
4417 1 : If (XWRK2 > XWRK3) Then
4418 0 : XHIGT (IFIN) = XWRK2
4419 0 : XHIGT (2) = XWRK3
4420 0 : XWRK2 = XWRK3
4421 0 : If (XWRK2 < XHIGT(1)) Then
4422 0 : XHIGT (2) = XHIGT (1)
4423 0 : XHIGT (1) = XWRK2
4424 : End If
4425 : End If
4426 : !
4427 1 : XWRK1 = XHIGT (1)
4428 1 : JLOW = JLOW + 1
4429 1 : XLOWT (JLOW) = XWRK1
4430 1 : XPIV = XWRK1 + 0.5 * (XHIGT(IFIN) - XWRK1)
4431 : !
4432 : ! One takes values <= pivot to XLOWT
4433 : ! Again, 2 parts, one where we take care of the remaining
4434 : ! high values because we might still need them, and the
4435 : ! other when we know that we will have more than enough
4436 : ! low values in the end.
4437 : !
4438 1 : JHIG = 0
4439 9 : Do ICRS = 2, IFIN
4440 9 : If (XHIGT(ICRS) <= XPIV) Then
4441 3 : JLOW = JLOW + 1
4442 3 : XLOWT (JLOW) = XHIGT (ICRS)
4443 3 : If (JLOW >= INTH) Exit
4444 : Else
4445 5 : JHIG = JHIG + 1
4446 5 : XHIGT (JHIG) = XHIGT (ICRS)
4447 : End If
4448 : End Do
4449 : !
4450 1 : Do ICRS = ICRS + 1, IFIN
4451 1 : If (XHIGT(ICRS) <= XPIV) Then
4452 0 : JLOW = JLOW + 1
4453 0 : XLOWT (JLOW) = XHIGT (ICRS)
4454 : End If
4455 : End Do
4456 : End Select
4457 : !
4458 : !
4459 : Case (1)
4460 : !
4461 : ! Only 1 value is missing in low part
4462 : !
4463 1 : XMIN = XHIGT(1)
4464 5 : Do ICRS = 2, JHIG
4465 5 : If (XHIGT(ICRS) < XMIN) Then
4466 1 : XMIN = XHIGT(ICRS)
4467 : End If
4468 : End Do
4469 : !
4470 1 : JLOW = JLOW + 1
4471 1 : XLOWT (JLOW) = XMIN
4472 1 : Exit
4473 : !
4474 : !
4475 : Case (0)
4476 : !
4477 : ! Low part is exactly what we want
4478 : !
4479 0 : Exit
4480 : !
4481 : !
4482 : Case (-5 : -1)
4483 : !
4484 : ! Only few values too many in low part
4485 : !
4486 0 : IF (IFODD) THEN
4487 0 : JHIG = JLOW - INTH + 1
4488 : Else
4489 0 : JHIG = JLOW - INTH + 2
4490 : end if
4491 0 : XHIGT (1) = XLOWT (1)
4492 0 : Do ICRS = 2, JHIG
4493 0 : XWRK = XLOWT (ICRS)
4494 0 : Do IDCR = ICRS - 1, 1, - 1
4495 0 : If (XWRK < XHIGT(IDCR)) Then
4496 0 : XHIGT (IDCR + 1) = XHIGT (IDCR)
4497 : Else
4498 : Exit
4499 : End If
4500 : End Do
4501 0 : XHIGT (IDCR + 1) = XWRK
4502 : End Do
4503 : !
4504 0 : Do ICRS = JHIG + 1, JLOW
4505 0 : If (XLOWT (ICRS) > XHIGT(1)) Then
4506 0 : XWRK = XLOWT (ICRS)
4507 0 : Do IDCR = 2, JHIG
4508 0 : If (XWRK >= XHIGT(IDCR)) Then
4509 0 : XHIGT (IDCR - 1) = XHIGT (IDCR)
4510 : else
4511 : exit
4512 : end if
4513 : End Do
4514 0 : XHIGT (IDCR - 1) = XWRK
4515 : End If
4516 : End Do
4517 : !
4518 0 : IF (IFODD) THEN
4519 0 : median = XHIGT(1)
4520 : Else
4521 0 : median = 0.5 * (XHIGT(1) + XHIGT(2))
4522 : end if
4523 0 : Return
4524 : !
4525 : !
4526 : Case (: -6)
4527 : !
4528 : ! last case: too many values in low part
4529 : !
4530 :
4531 0 : IMIL = (JLOW + 1) / 2
4532 0 : IFIN = JLOW
4533 : !
4534 : ! One chooses a pivot from 1st, last, and middle values
4535 : !
4536 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
4537 0 : XWRK = XLOWT (1)
4538 0 : XLOWT (1) = XLOWT (IMIL)
4539 0 : XLOWT (IMIL) = XWRK
4540 : End If
4541 0 : If (XLOWT(IMIL) > XLOWT(IFIN)) Then
4542 0 : XWRK = XLOWT (IFIN)
4543 0 : XLOWT (IFIN) = XLOWT (IMIL)
4544 0 : XLOWT (IMIL) = XWRK
4545 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
4546 0 : XWRK = XLOWT (1)
4547 0 : XLOWT (1) = XLOWT (IMIL)
4548 0 : XLOWT (IMIL) = XWRK
4549 : End If
4550 : End If
4551 0 : If (IFIN <= 3) Exit
4552 : !
4553 : XPIV = XLOWT(1) + REAL(INTH, dp) / REAL(JLOW + INTH, dp) * &
4554 0 : (XLOWT(IFIN) - XLOWT(1))
4555 :
4556 : !
4557 : ! One takes values > XPIV to XHIGT
4558 : !
4559 0 : JHIG = 0
4560 0 : JLOW = 0
4561 : !
4562 2 : If (XLOWT(IFIN) > XPIV) Then
4563 : ICRS = 0
4564 : Do
4565 0 : ICRS = ICRS + 1
4566 0 : If (XLOWT(ICRS) > XPIV) Then
4567 0 : JHIG = JHIG + 1
4568 0 : XHIGT (JHIG) = XLOWT (ICRS)
4569 0 : If (ICRS >= IFIN) Exit
4570 : Else
4571 0 : JLOW = JLOW + 1
4572 0 : XLOWT (JLOW) = XLOWT (ICRS)
4573 0 : If (JLOW >= INTH) Exit
4574 : End If
4575 : End Do
4576 : !
4577 0 : If (ICRS < IFIN) Then
4578 : Do
4579 0 : ICRS = ICRS + 1
4580 0 : If (XLOWT(ICRS) <= XPIV) Then
4581 0 : JLOW = JLOW + 1
4582 0 : XLOWT (JLOW) = XLOWT (ICRS)
4583 : Else
4584 0 : If (ICRS >= IFIN) Exit
4585 : End If
4586 : End Do
4587 : End If
4588 : Else
4589 0 : Do ICRS = 1, IFIN
4590 0 : If (XLOWT(ICRS) > XPIV) Then
4591 0 : JHIG = JHIG + 1
4592 0 : XHIGT (JHIG) = XLOWT (ICRS)
4593 : Else
4594 0 : JLOW = JLOW + 1
4595 0 : XLOWT (JLOW) = XLOWT (ICRS)
4596 0 : If (JLOW >= INTH) Exit
4597 : End If
4598 : End Do
4599 : !
4600 0 : Do ICRS = ICRS + 1, IFIN
4601 0 : If (XLOWT(ICRS) <= XPIV) Then
4602 0 : JLOW = JLOW + 1
4603 0 : XLOWT (JLOW) = XLOWT (ICRS)
4604 : End If
4605 : End Do
4606 : End If
4607 : !
4608 : End Select
4609 : !
4610 : End Do
4611 : !
4612 : ! Now, we only need to find maximum of the 1:INTH set
4613 : !
4614 1 : if (IFODD) then
4615 0 : median = MAXVAL (XLOWT (1 : INTH))
4616 : else
4617 1 : XWRK = MAX (XLOWT (1), XLOWT (2))
4618 1 : XWRK1 = MIN (XLOWT (1), XLOWT (2))
4619 4 : DO ICRS = 3, INTH
4620 4 : IF (XLOWT (ICRS) > XWRK1) THEN
4621 3 : IF (XLOWT (ICRS) > XWRK) THEN
4622 : XWRK1 = XWRK
4623 : XWRK = XLOWT (ICRS)
4624 : Else
4625 0 : XWRK1 = XLOWT (ICRS)
4626 : end if
4627 : end if
4628 : ENDDO
4629 1 : median = 0.5 * (XWRK + XWRK1)
4630 : end if
4631 : Return
4632 : !
4633 0 : End Function D_median
4634 :
4635 1 : Function R_median (XDONT) Result (median)
4636 : ! Return median value of XDONT
4637 : ! __________________________________________________________
4638 : ! This routine uses a pivoting strategy such as the one of
4639 : ! finding the median based on the quicksort algorithm, but
4640 : ! we skew the pivot choice to try to bring it to NORD as
4641 : ! fast as possible. It uses 2 temporary arrays, where it
4642 : ! stores the indices of the values smaller than the pivot
4643 : ! (ILOWT), and the indices of values larger than the pivot
4644 : ! that we might still need later on (IHIGT). It iterates
4645 : ! until it can bring the number of values in ILOWT to
4646 : ! exactly NORD, and then finds the maximum of this set.
4647 : ! Michel Olagnon - Aug. 2000
4648 : ! __________________________________________________________
4649 : ! _________________________________________________________
4650 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
4651 : Real(kind = sp) :: median
4652 : ! __________________________________________________________
4653 22 : Real(kind = sp), Dimension (SIZE(XDONT)) :: XLOWT, XHIGT
4654 1 : Real(kind = sp) :: XPIV, XWRK, XWRK1, XWRK2, XWRK3, XMIN, XMAX
4655 : !!
4656 : Logical :: IFODD
4657 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG!, NORD
4658 : Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR!, ILOW
4659 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
4660 : !
4661 1 : NDON = SIZE (XDONT)
4662 1 : INTH = NDON / 2 + 1
4663 1 : IFODD = (2 * INTH == NDON + 1)
4664 : !
4665 : ! First loop is used to fill-in XLOWT, XHIGT at the same time
4666 : !
4667 1 : If (NDON < 3) Then
4668 0 : If (NDON > 0) median = 0.5 * (XDONT (1) + XDONT (NDON))
4669 0 : Return
4670 : End If
4671 : !
4672 : ! One chooses a pivot, best estimate possible to put fractile near
4673 : ! mid-point of the set of low values.
4674 : !
4675 1 : If (XDONT(2) < XDONT(1)) Then
4676 0 : XLOWT (1) = XDONT(2)
4677 0 : XHIGT (1) = XDONT(1)
4678 : Else
4679 1 : XLOWT (1) = XDONT(1)
4680 1 : XHIGT (1) = XDONT(2)
4681 : End If
4682 : !
4683 : !
4684 1 : If (XDONT(3) < XHIGT(1)) Then
4685 0 : XHIGT (2) = XHIGT (1)
4686 0 : If (XDONT(3) < XLOWT(1)) Then
4687 0 : XHIGT (1) = XLOWT (1)
4688 0 : XLOWT (1) = XDONT(3)
4689 : Else
4690 0 : XHIGT (1) = XDONT(3)
4691 : End If
4692 : Else
4693 1 : XHIGT (2) = XDONT(3)
4694 : End If
4695 : !
4696 1 : If (NDON < 4) Then ! 3 values
4697 0 : median = XHIGT (1)
4698 0 : Return
4699 : End If
4700 : !
4701 1 : If (XDONT(NDON) < XHIGT(1)) Then
4702 0 : XHIGT (3) = XHIGT (2)
4703 0 : XHIGT (2) = XHIGT (1)
4704 0 : If (XDONT(NDON) < XLOWT(1)) Then
4705 0 : XHIGT (1) = XLOWT (1)
4706 0 : XLOWT (1) = XDONT(NDON)
4707 : Else
4708 0 : XHIGT (1) = XDONT(NDON)
4709 : End If
4710 : Else
4711 1 : If (XDONT(NDON) < XHIGT(2)) Then
4712 0 : XHIGT (3) = XHIGT (2)
4713 0 : XHIGT (2) = XDONT(NDON)
4714 : Else
4715 1 : XHIGT (3) = XDONT(NDON)
4716 : End If
4717 : End If
4718 : !
4719 1 : If (NDON < 5) Then ! 4 values
4720 0 : median = 0.5 * (XHIGT (1) + XHIGT (2))
4721 0 : Return
4722 : End If
4723 : !
4724 1 : JLOW = 1
4725 1 : JHIG = 3
4726 1 : XPIV = XLOWT(1) + 2.0 * (XHIGT(3) - XLOWT(1)) / 3.0
4727 1 : If (XPIV >= XHIGT(1)) Then
4728 1 : XPIV = XLOWT(1) + 2.0 * (XHIGT(2) - XLOWT(1)) / 3.0
4729 1 : If (XPIV >= XHIGT(1)) XPIV = XLOWT(1) + 2.0 * (XHIGT(1) - XLOWT(1)) / 3.0
4730 : End If
4731 : !
4732 : ! One puts values > pivot in the end and those <= pivot
4733 : ! at the beginning. This is split in 2 cases, so that
4734 : ! we can skip the loop test a number of times.
4735 : ! As we are also filling in the work arrays at the same time
4736 : ! we stop filling in the XHIGT array as soon as we have more
4737 : ! than enough values in XLOWT.
4738 : !
4739 : !
4740 1 : If (XDONT(NDON) > XPIV) Then
4741 : ICRS = 3
4742 : Do
4743 7 : ICRS = ICRS + 1
4744 8 : If (XDONT(ICRS) > XPIV) Then
4745 7 : If (ICRS >= NDON) Exit
4746 6 : JHIG = JHIG + 1
4747 6 : XHIGT (JHIG) = XDONT(ICRS)
4748 : Else
4749 0 : JLOW = JLOW + 1
4750 0 : XLOWT (JLOW) = XDONT(ICRS)
4751 0 : If (JLOW >= INTH) Exit
4752 : End If
4753 : End Do
4754 : !
4755 : ! One restricts further processing because it is no use
4756 : ! to store more high values
4757 : !
4758 1 : If (ICRS < NDON - 1) Then
4759 : Do
4760 0 : ICRS = ICRS + 1
4761 0 : If (XDONT(ICRS) <= XPIV) Then
4762 0 : JLOW = JLOW + 1
4763 0 : XLOWT (JLOW) = XDONT(ICRS)
4764 0 : Else If (ICRS >= NDON) Then
4765 : Exit
4766 : End If
4767 : End Do
4768 : End If
4769 : !
4770 : !
4771 : Else
4772 : !
4773 : ! Same as above, but this is not as easy to optimize, so the
4774 : ! DO-loop is kept
4775 : !
4776 0 : Do ICRS = 4, NDON - 1
4777 0 : If (XDONT(ICRS) > XPIV) Then
4778 0 : JHIG = JHIG + 1
4779 0 : XHIGT (JHIG) = XDONT(ICRS)
4780 : Else
4781 0 : JLOW = JLOW + 1
4782 0 : XLOWT (JLOW) = XDONT(ICRS)
4783 0 : If (JLOW >= INTH) Exit
4784 : End If
4785 : End Do
4786 : !
4787 0 : If (ICRS < NDON - 1) Then
4788 : Do
4789 0 : ICRS = ICRS + 1
4790 0 : If (XDONT(ICRS) <= XPIV) Then
4791 0 : If (ICRS >= NDON) Exit
4792 0 : JLOW = JLOW + 1
4793 0 : XLOWT (JLOW) = XDONT(ICRS)
4794 : End If
4795 : End Do
4796 : End If
4797 : End If
4798 : !
4799 : JLM2 = 0
4800 : JLM1 = 0
4801 : JHM2 = 0
4802 : JHM1 = 0
4803 : Do
4804 2 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
4805 : !
4806 : ! We are oscillating. Perturbate by bringing JLOW closer by one
4807 : ! to INTH
4808 : !
4809 0 : If (INTH > JLOW) Then
4810 0 : XMIN = XHIGT(1)
4811 0 : IHIG = 1
4812 0 : Do ICRS = 2, JHIG
4813 0 : If (XHIGT(ICRS) < XMIN) Then
4814 0 : XMIN = XHIGT(ICRS)
4815 0 : IHIG = ICRS
4816 : End If
4817 : End Do
4818 : !
4819 0 : JLOW = JLOW + 1
4820 0 : XLOWT (JLOW) = XHIGT (IHIG)
4821 0 : XHIGT (IHIG) = XHIGT (JHIG)
4822 0 : JHIG = JHIG - 1
4823 : Else
4824 :
4825 0 : XMAX = XLOWT (JLOW)
4826 0 : JLOW = JLOW - 1
4827 0 : Do ICRS = 1, JLOW
4828 0 : If (XLOWT(ICRS) > XMAX) Then
4829 0 : XWRK = XMAX
4830 0 : XMAX = XLOWT(ICRS)
4831 0 : XLOWT (ICRS) = XWRK
4832 : End If
4833 : End Do
4834 : End If
4835 : End If
4836 2 : JLM2 = JLM1
4837 2 : JLM1 = JLOW
4838 2 : JHM2 = JHM1
4839 2 : JHM1 = JHIG
4840 : !
4841 : ! We try to bring the number of values in the low values set
4842 : ! closer to INTH.
4843 : !
4844 3 : Select Case (INTH - JLOW)
4845 : Case (2 :)
4846 : !
4847 : ! Not enough values in low part, at least 2 are missing
4848 : !
4849 1 : INTH = INTH - JLOW
4850 1 : JLOW = 0
4851 : Select Case (JHIG)
4852 : !!!!! CASE DEFAULT
4853 : !!!!! write (unit=*,fmt=*) "Assertion failed"
4854 : !!!!! STOP
4855 : !
4856 : ! We make a special case when we have so few values in
4857 : ! the high values set that it is bad performance to choose a pivot
4858 : ! and apply the general algorithm.
4859 : !
4860 : Case (2)
4861 0 : If (XHIGT(1) <= XHIGT(2)) Then
4862 0 : JLOW = JLOW + 1
4863 0 : XLOWT (JLOW) = XHIGT (1)
4864 0 : JLOW = JLOW + 1
4865 0 : XLOWT (JLOW) = XHIGT (2)
4866 : Else
4867 0 : JLOW = JLOW + 1
4868 0 : XLOWT (JLOW) = XHIGT (2)
4869 0 : JLOW = JLOW + 1
4870 0 : XLOWT (JLOW) = XHIGT (1)
4871 : End If
4872 : Exit
4873 : !
4874 : Case (3)
4875 : !
4876 : !
4877 0 : XWRK1 = XHIGT (1)
4878 0 : XWRK2 = XHIGT (2)
4879 0 : XWRK3 = XHIGT (3)
4880 0 : If (XWRK2 < XWRK1) Then
4881 0 : XHIGT (1) = XWRK2
4882 0 : XHIGT (2) = XWRK1
4883 0 : XWRK2 = XWRK1
4884 : End If
4885 0 : If (XWRK2 > XWRK3) Then
4886 0 : XHIGT (3) = XWRK2
4887 0 : XHIGT (2) = XWRK3
4888 0 : XWRK2 = XWRK3
4889 0 : If (XWRK2 < XHIGT(1)) Then
4890 0 : XHIGT (2) = XHIGT (1)
4891 0 : XHIGT (1) = XWRK2
4892 : End If
4893 : End If
4894 : JHIG = 0
4895 0 : Do ICRS = JLOW + 1, INTH
4896 0 : JHIG = JHIG + 1
4897 0 : XLOWT (ICRS) = XHIGT (JHIG)
4898 : End Do
4899 1 : JLOW = INTH
4900 : Exit
4901 : !
4902 : Case (4 :)
4903 : !
4904 : !
4905 1 : IFIN = JHIG
4906 : !
4907 : ! One chooses a pivot from the 2 first values and the last one.
4908 : ! This should ensure sufficient renewal between iterations to
4909 : ! avoid worst case behavior effects.
4910 : !
4911 1 : XWRK1 = XHIGT (1)
4912 1 : XWRK2 = XHIGT (2)
4913 1 : XWRK3 = XHIGT (IFIN)
4914 1 : If (XWRK2 < XWRK1) Then
4915 0 : XHIGT (1) = XWRK2
4916 0 : XHIGT (2) = XWRK1
4917 0 : XWRK2 = XWRK1
4918 : End If
4919 1 : If (XWRK2 > XWRK3) Then
4920 0 : XHIGT (IFIN) = XWRK2
4921 0 : XHIGT (2) = XWRK3
4922 0 : XWRK2 = XWRK3
4923 0 : If (XWRK2 < XHIGT(1)) Then
4924 0 : XHIGT (2) = XHIGT (1)
4925 0 : XHIGT (1) = XWRK2
4926 : End If
4927 : End If
4928 : !
4929 1 : XWRK1 = XHIGT (1)
4930 1 : JLOW = JLOW + 1
4931 1 : XLOWT (JLOW) = XWRK1
4932 1 : XPIV = XWRK1 + 0.5 * (XHIGT(IFIN) - XWRK1)
4933 : !
4934 : ! One takes values <= pivot to XLOWT
4935 : ! Again, 2 parts, one where we take care of the remaining
4936 : ! high values because we might still need them, and the
4937 : ! other when we know that we will have more than enough
4938 : ! low values in the end.
4939 : !
4940 1 : JHIG = 0
4941 9 : Do ICRS = 2, IFIN
4942 9 : If (XHIGT(ICRS) <= XPIV) Then
4943 3 : JLOW = JLOW + 1
4944 3 : XLOWT (JLOW) = XHIGT (ICRS)
4945 3 : If (JLOW >= INTH) Exit
4946 : Else
4947 5 : JHIG = JHIG + 1
4948 5 : XHIGT (JHIG) = XHIGT (ICRS)
4949 : End If
4950 : End Do
4951 : !
4952 1 : Do ICRS = ICRS + 1, IFIN
4953 1 : If (XHIGT(ICRS) <= XPIV) Then
4954 0 : JLOW = JLOW + 1
4955 0 : XLOWT (JLOW) = XHIGT (ICRS)
4956 : End If
4957 : End Do
4958 : End Select
4959 : !
4960 : !
4961 : Case (1)
4962 : !
4963 : ! Only 1 value is missing in low part
4964 : !
4965 1 : XMIN = XHIGT(1)
4966 5 : Do ICRS = 2, JHIG
4967 5 : If (XHIGT(ICRS) < XMIN) Then
4968 1 : XMIN = XHIGT(ICRS)
4969 : End If
4970 : End Do
4971 : !
4972 1 : JLOW = JLOW + 1
4973 1 : XLOWT (JLOW) = XMIN
4974 1 : Exit
4975 : !
4976 : !
4977 : Case (0)
4978 : !
4979 : ! Low part is exactly what we want
4980 : !
4981 0 : Exit
4982 : !
4983 : !
4984 : Case (-5 : -1)
4985 : !
4986 : ! Only few values too many in low part
4987 : !
4988 0 : IF (IFODD) THEN
4989 0 : JHIG = JLOW - INTH + 1
4990 : Else
4991 0 : JHIG = JLOW - INTH + 2
4992 : end if
4993 0 : XHIGT (1) = XLOWT (1)
4994 0 : Do ICRS = 2, JHIG
4995 0 : XWRK = XLOWT (ICRS)
4996 0 : Do IDCR = ICRS - 1, 1, - 1
4997 0 : If (XWRK < XHIGT(IDCR)) Then
4998 0 : XHIGT (IDCR + 1) = XHIGT (IDCR)
4999 : Else
5000 : Exit
5001 : End If
5002 : End Do
5003 0 : XHIGT (IDCR + 1) = XWRK
5004 : End Do
5005 : !
5006 0 : Do ICRS = JHIG + 1, JLOW
5007 0 : If (XLOWT (ICRS) > XHIGT(1)) Then
5008 0 : XWRK = XLOWT (ICRS)
5009 0 : Do IDCR = 2, JHIG
5010 0 : If (XWRK >= XHIGT(IDCR)) Then
5011 0 : XHIGT (IDCR - 1) = XHIGT (IDCR)
5012 : else
5013 : exit
5014 : end if
5015 : End Do
5016 0 : XHIGT (IDCR - 1) = XWRK
5017 : End If
5018 : End Do
5019 : !
5020 0 : IF (IFODD) THEN
5021 0 : median = XHIGT(1)
5022 : Else
5023 0 : median = 0.5 * (XHIGT(1) + XHIGT(2))
5024 : end if
5025 0 : Return
5026 : !
5027 : !
5028 : Case (: -6)
5029 : !
5030 : ! last case: too many values in low part
5031 : !
5032 :
5033 0 : IMIL = (JLOW + 1) / 2
5034 0 : IFIN = JLOW
5035 : !
5036 : ! One chooses a pivot from 1st, last, and middle values
5037 : !
5038 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
5039 0 : XWRK = XLOWT (1)
5040 0 : XLOWT (1) = XLOWT (IMIL)
5041 0 : XLOWT (IMIL) = XWRK
5042 : End If
5043 0 : If (XLOWT(IMIL) > XLOWT(IFIN)) Then
5044 0 : XWRK = XLOWT (IFIN)
5045 0 : XLOWT (IFIN) = XLOWT (IMIL)
5046 0 : XLOWT (IMIL) = XWRK
5047 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
5048 0 : XWRK = XLOWT (1)
5049 0 : XLOWT (1) = XLOWT (IMIL)
5050 0 : XLOWT (IMIL) = XWRK
5051 : End If
5052 : End If
5053 0 : If (IFIN <= 3) Exit
5054 : !
5055 : XPIV = XLOWT(1) + REAL(INTH, sp) / REAL(JLOW + INTH, sp) * &
5056 0 : (XLOWT(IFIN) - XLOWT(1))
5057 :
5058 : !
5059 : ! One takes values > XPIV to XHIGT
5060 : !
5061 0 : JHIG = 0
5062 0 : JLOW = 0
5063 : !
5064 2 : If (XLOWT(IFIN) > XPIV) Then
5065 : ICRS = 0
5066 : Do
5067 0 : ICRS = ICRS + 1
5068 0 : If (XLOWT(ICRS) > XPIV) Then
5069 0 : JHIG = JHIG + 1
5070 0 : XHIGT (JHIG) = XLOWT (ICRS)
5071 0 : If (ICRS >= IFIN) Exit
5072 : Else
5073 0 : JLOW = JLOW + 1
5074 0 : XLOWT (JLOW) = XLOWT (ICRS)
5075 0 : If (JLOW >= INTH) Exit
5076 : End If
5077 : End Do
5078 : !
5079 0 : If (ICRS < IFIN) Then
5080 : Do
5081 0 : ICRS = ICRS + 1
5082 0 : If (XLOWT(ICRS) <= XPIV) Then
5083 0 : JLOW = JLOW + 1
5084 0 : XLOWT (JLOW) = XLOWT (ICRS)
5085 : Else
5086 0 : If (ICRS >= IFIN) Exit
5087 : End If
5088 : End Do
5089 : End If
5090 : Else
5091 0 : Do ICRS = 1, IFIN
5092 0 : If (XLOWT(ICRS) > XPIV) Then
5093 0 : JHIG = JHIG + 1
5094 0 : XHIGT (JHIG) = XLOWT (ICRS)
5095 : Else
5096 0 : JLOW = JLOW + 1
5097 0 : XLOWT (JLOW) = XLOWT (ICRS)
5098 0 : If (JLOW >= INTH) Exit
5099 : End If
5100 : End Do
5101 : !
5102 0 : Do ICRS = ICRS + 1, IFIN
5103 0 : If (XLOWT(ICRS) <= XPIV) Then
5104 0 : JLOW = JLOW + 1
5105 0 : XLOWT (JLOW) = XLOWT (ICRS)
5106 : End If
5107 : End Do
5108 : End If
5109 : !
5110 : End Select
5111 : !
5112 : End Do
5113 : !
5114 : ! Now, we only need to find maximum of the 1:INTH set
5115 : !
5116 1 : if (IFODD) then
5117 0 : median = MAXVAL (XLOWT (1 : INTH))
5118 : else
5119 1 : XWRK = MAX (XLOWT (1), XLOWT (2))
5120 1 : XWRK1 = MIN (XLOWT (1), XLOWT (2))
5121 4 : DO ICRS = 3, INTH
5122 4 : IF (XLOWT (ICRS) > XWRK1) THEN
5123 3 : IF (XLOWT (ICRS) > XWRK) THEN
5124 : XWRK1 = XWRK
5125 : XWRK = XLOWT (ICRS)
5126 : Else
5127 0 : XWRK1 = XLOWT (ICRS)
5128 : end if
5129 : end if
5130 : ENDDO
5131 1 : median = 0.5 * (XWRK + XWRK1)
5132 : end if
5133 : Return
5134 : !
5135 1 : End Function R_median
5136 :
5137 0 : Function I_median (XDONT) Result (median)
5138 : ! Return median value of XDONT
5139 : ! __________________________________________________________
5140 : ! This routine uses a pivoting strategy such as the one of
5141 : ! finding the median based on the quicksort algorithm, but
5142 : ! we skew the pivot choice to try to bring it to NORD as
5143 : ! fast as possible. It uses 2 temporary arrays, where it
5144 : ! stores the indices of the values smaller than the pivot
5145 : ! (ILOWT), and the indices of values larger than the pivot
5146 : ! that we might still need later on (IHIGT). It iterates
5147 : ! until it can bring the number of values in ILOWT to
5148 : ! exactly NORD, and then finds the maximum of this set.
5149 : ! Michel Olagnon - Aug. 2000
5150 : ! __________________________________________________________
5151 : ! __________________________________________________________
5152 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
5153 : Integer(kind = i4) :: median
5154 : ! __________________________________________________________
5155 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: XLOWT, XHIGT
5156 : Integer(kind = i4) :: XPIV, XWRK, XWRK1, XWRK2, XWRK3, XMIN, XMAX
5157 : !!
5158 : Logical :: IFODD
5159 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG!, NORD
5160 : Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR!, ILOW
5161 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
5162 : !
5163 0 : NDON = SIZE (XDONT)
5164 0 : INTH = NDON / 2 + 1
5165 0 : IFODD = (2 * INTH == NDON + 1)
5166 : !
5167 : ! First loop is used to fill-in XLOWT, XHIGT at the same time
5168 : !
5169 0 : If (NDON < 3) Then
5170 0 : If (NDON > 0) median = (XDONT (1) + XDONT (NDON)) / 2
5171 0 : Return
5172 : End If
5173 : !
5174 : ! One chooses a pivot, best estimate possible to put fractile near
5175 : ! mid-point of the set of low values.
5176 : !
5177 0 : If (XDONT(2) < XDONT(1)) Then
5178 0 : XLOWT (1) = XDONT(2)
5179 0 : XHIGT (1) = XDONT(1)
5180 : Else
5181 0 : XLOWT (1) = XDONT(1)
5182 0 : XHIGT (1) = XDONT(2)
5183 : End If
5184 : !
5185 : !
5186 0 : If (XDONT(3) < XHIGT(1)) Then
5187 0 : XHIGT (2) = XHIGT (1)
5188 0 : If (XDONT(3) < XLOWT(1)) Then
5189 0 : XHIGT (1) = XLOWT (1)
5190 0 : XLOWT (1) = XDONT(3)
5191 : Else
5192 0 : XHIGT (1) = XDONT(3)
5193 : End If
5194 : Else
5195 0 : XHIGT (2) = XDONT(3)
5196 : End If
5197 : !
5198 0 : If (NDON < 4) Then ! 3 values
5199 0 : median = XHIGT (1)
5200 0 : Return
5201 : End If
5202 : !
5203 0 : If (XDONT(NDON) < XHIGT(1)) Then
5204 0 : XHIGT (3) = XHIGT (2)
5205 0 : XHIGT (2) = XHIGT (1)
5206 0 : If (XDONT(NDON) < XLOWT(1)) Then
5207 0 : XHIGT (1) = XLOWT (1)
5208 0 : XLOWT (1) = XDONT(NDON)
5209 : Else
5210 0 : XHIGT (1) = XDONT(NDON)
5211 : End If
5212 : Else
5213 0 : If (XDONT(NDON) < XHIGT(2)) Then
5214 0 : XHIGT (3) = XHIGT (2)
5215 0 : XHIGT (2) = XDONT(NDON)
5216 : Else
5217 0 : XHIGT (3) = XDONT(NDON)
5218 : End If
5219 : End If
5220 : !
5221 0 : If (NDON < 5) Then ! 4 values
5222 0 : median = (XHIGT (1) + XHIGT (2)) / 2
5223 0 : Return
5224 : End If
5225 : !
5226 0 : JLOW = 1
5227 0 : JHIG = 3
5228 0 : XPIV = XLOWT(1) + 2 * (XHIGT(3) - XLOWT(1)) / 3
5229 0 : If (XPIV >= XHIGT(1)) Then
5230 0 : XPIV = XLOWT(1) + 2 * (XHIGT(2) - XLOWT(1)) / 3
5231 0 : If (XPIV >= XHIGT(1)) XPIV = XLOWT(1) + 2 * (XHIGT(1) - XLOWT(1)) / 3
5232 : End If
5233 : !
5234 : ! One puts values > pivot in the end and those <= pivot
5235 : ! at the beginning. This is split in 2 cases, so that
5236 : ! we can skip the loop test a number of times.
5237 : ! As we are also filling in the work arrays at the same time
5238 : ! we stop filling in the XHIGT array as soon as we have more
5239 : ! than enough values in XLOWT.
5240 : !
5241 : !
5242 0 : If (XDONT(NDON) > XPIV) Then
5243 : ICRS = 3
5244 : Do
5245 0 : ICRS = ICRS + 1
5246 0 : If (XDONT(ICRS) > XPIV) Then
5247 0 : If (ICRS >= NDON) Exit
5248 0 : JHIG = JHIG + 1
5249 0 : XHIGT (JHIG) = XDONT(ICRS)
5250 : Else
5251 0 : JLOW = JLOW + 1
5252 0 : XLOWT (JLOW) = XDONT(ICRS)
5253 0 : If (JLOW >= INTH) Exit
5254 : End If
5255 : End Do
5256 : !
5257 : ! One restricts further processing because it is no use
5258 : ! to store more high values
5259 : !
5260 0 : If (ICRS < NDON - 1) Then
5261 : Do
5262 0 : ICRS = ICRS + 1
5263 0 : If (XDONT(ICRS) <= XPIV) Then
5264 0 : JLOW = JLOW + 1
5265 0 : XLOWT (JLOW) = XDONT(ICRS)
5266 0 : Else If (ICRS >= NDON) Then
5267 : Exit
5268 : End If
5269 : End Do
5270 : End If
5271 : !
5272 : !
5273 : Else
5274 : !
5275 : ! Same as above, but this is not as easy to optimize, so the
5276 : ! DO-loop is kept
5277 : !
5278 0 : Do ICRS = 4, NDON - 1
5279 0 : If (XDONT(ICRS) > XPIV) Then
5280 0 : JHIG = JHIG + 1
5281 0 : XHIGT (JHIG) = XDONT(ICRS)
5282 : Else
5283 0 : JLOW = JLOW + 1
5284 0 : XLOWT (JLOW) = XDONT(ICRS)
5285 0 : If (JLOW >= INTH) Exit
5286 : End If
5287 : End Do
5288 : !
5289 0 : If (ICRS < NDON - 1) Then
5290 : Do
5291 0 : ICRS = ICRS + 1
5292 0 : If (XDONT(ICRS) <= XPIV) Then
5293 0 : If (ICRS >= NDON) Exit
5294 0 : JLOW = JLOW + 1
5295 0 : XLOWT (JLOW) = XDONT(ICRS)
5296 : End If
5297 : End Do
5298 : End If
5299 : End If
5300 : !
5301 : JLM2 = 0
5302 : JLM1 = 0
5303 : JHM2 = 0
5304 : JHM1 = 0
5305 : Do
5306 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
5307 : !
5308 : ! We are oscillating. Perturbate by bringing JLOW closer by one
5309 : ! to INTH
5310 : !
5311 0 : If (INTH > JLOW) Then
5312 0 : XMIN = XHIGT(1)
5313 0 : IHIG = 1
5314 0 : Do ICRS = 2, JHIG
5315 0 : If (XHIGT(ICRS) < XMIN) Then
5316 0 : XMIN = XHIGT(ICRS)
5317 0 : IHIG = ICRS
5318 : End If
5319 : End Do
5320 : !
5321 0 : JLOW = JLOW + 1
5322 0 : XLOWT (JLOW) = XHIGT (IHIG)
5323 0 : XHIGT (IHIG) = XHIGT (JHIG)
5324 0 : JHIG = JHIG - 1
5325 : Else
5326 :
5327 0 : XMAX = XLOWT (JLOW)
5328 0 : JLOW = JLOW - 1
5329 0 : Do ICRS = 1, JLOW
5330 0 : If (XLOWT(ICRS) > XMAX) Then
5331 0 : XWRK = XMAX
5332 0 : XMAX = XLOWT(ICRS)
5333 0 : XLOWT (ICRS) = XWRK
5334 : End If
5335 : End Do
5336 : End If
5337 : End If
5338 0 : JLM2 = JLM1
5339 0 : JLM1 = JLOW
5340 0 : JHM2 = JHM1
5341 0 : JHM1 = JHIG
5342 : !
5343 : ! We try to bring the number of values in the low values set
5344 : ! closer to INTH.
5345 : !
5346 0 : Select Case (INTH - JLOW)
5347 : Case (2 :)
5348 : !
5349 : ! Not enough values in low part, at least 2 are missing
5350 : !
5351 0 : INTH = INTH - JLOW
5352 0 : JLOW = 0
5353 : Select Case (JHIG)
5354 : !!!!! CASE DEFAULT
5355 : !!!!! write (unit=*,fmt=*) "Assertion failed"
5356 : !!!!! STOP
5357 : !
5358 : ! We make a special case when we have so few values in
5359 : ! the high values set that it is bad performance to choose a pivot
5360 : ! and apply the general algorithm.
5361 : !
5362 : Case (2)
5363 0 : If (XHIGT(1) <= XHIGT(2)) Then
5364 0 : JLOW = JLOW + 1
5365 0 : XLOWT (JLOW) = XHIGT (1)
5366 0 : JLOW = JLOW + 1
5367 0 : XLOWT (JLOW) = XHIGT (2)
5368 : Else
5369 0 : JLOW = JLOW + 1
5370 0 : XLOWT (JLOW) = XHIGT (2)
5371 0 : JLOW = JLOW + 1
5372 0 : XLOWT (JLOW) = XHIGT (1)
5373 : End If
5374 : Exit
5375 : !
5376 : Case (3)
5377 : !
5378 : !
5379 0 : XWRK1 = XHIGT (1)
5380 0 : XWRK2 = XHIGT (2)
5381 0 : XWRK3 = XHIGT (3)
5382 0 : If (XWRK2 < XWRK1) Then
5383 0 : XHIGT (1) = XWRK2
5384 0 : XHIGT (2) = XWRK1
5385 0 : XWRK2 = XWRK1
5386 : End If
5387 0 : If (XWRK2 > XWRK3) Then
5388 0 : XHIGT (3) = XWRK2
5389 0 : XHIGT (2) = XWRK3
5390 0 : XWRK2 = XWRK3
5391 0 : If (XWRK2 < XHIGT(1)) Then
5392 0 : XHIGT (2) = XHIGT (1)
5393 0 : XHIGT (1) = XWRK2
5394 : End If
5395 : End If
5396 : JHIG = 0
5397 0 : Do ICRS = JLOW + 1, INTH
5398 0 : JHIG = JHIG + 1
5399 0 : XLOWT (ICRS) = XHIGT (JHIG)
5400 : End Do
5401 0 : JLOW = INTH
5402 : Exit
5403 : !
5404 : Case (4 :)
5405 : !
5406 : !
5407 0 : IFIN = JHIG
5408 : !
5409 : ! One chooses a pivot from the 2 first values and the last one.
5410 : ! This should ensure sufficient renewal between iterations to
5411 : ! avoid worst case behavior effects.
5412 : !
5413 0 : XWRK1 = XHIGT (1)
5414 0 : XWRK2 = XHIGT (2)
5415 0 : XWRK3 = XHIGT (IFIN)
5416 0 : If (XWRK2 < XWRK1) Then
5417 0 : XHIGT (1) = XWRK2
5418 0 : XHIGT (2) = XWRK1
5419 0 : XWRK2 = XWRK1
5420 : End If
5421 0 : If (XWRK2 > XWRK3) Then
5422 0 : XHIGT (IFIN) = XWRK2
5423 0 : XHIGT (2) = XWRK3
5424 0 : XWRK2 = XWRK3
5425 0 : If (XWRK2 < XHIGT(1)) Then
5426 0 : XHIGT (2) = XHIGT (1)
5427 0 : XHIGT (1) = XWRK2
5428 : End If
5429 : End If
5430 : !
5431 0 : XWRK1 = XHIGT (1)
5432 0 : JLOW = JLOW + 1
5433 0 : XLOWT (JLOW) = XWRK1
5434 0 : XPIV = XWRK1 + (XHIGT(IFIN) - XWRK1) / 2
5435 : !
5436 : ! One takes values <= pivot to XLOWT
5437 : ! Again, 2 parts, one where we take care of the remaining
5438 : ! high values because we might still need them, and the
5439 : ! other when we know that we will have more than enough
5440 : ! low values in the end.
5441 : !
5442 0 : JHIG = 0
5443 0 : Do ICRS = 2, IFIN
5444 0 : If (XHIGT(ICRS) <= XPIV) Then
5445 0 : JLOW = JLOW + 1
5446 0 : XLOWT (JLOW) = XHIGT (ICRS)
5447 0 : If (JLOW >= INTH) Exit
5448 : Else
5449 0 : JHIG = JHIG + 1
5450 0 : XHIGT (JHIG) = XHIGT (ICRS)
5451 : End If
5452 : End Do
5453 : !
5454 0 : Do ICRS = ICRS + 1, IFIN
5455 0 : If (XHIGT(ICRS) <= XPIV) Then
5456 0 : JLOW = JLOW + 1
5457 0 : XLOWT (JLOW) = XHIGT (ICRS)
5458 : End If
5459 : End Do
5460 : End Select
5461 : !
5462 : !
5463 : Case (1)
5464 : !
5465 : ! Only 1 value is missing in low part
5466 : !
5467 0 : XMIN = XHIGT(1)
5468 0 : Do ICRS = 2, JHIG
5469 0 : If (XHIGT(ICRS) < XMIN) Then
5470 0 : XMIN = XHIGT(ICRS)
5471 : End If
5472 : End Do
5473 : !
5474 0 : JLOW = JLOW + 1
5475 0 : XLOWT (JLOW) = XMIN
5476 0 : Exit
5477 : !
5478 : !
5479 : Case (0)
5480 : !
5481 : ! Low part is exactly what we want
5482 : !
5483 0 : Exit
5484 : !
5485 : !
5486 : Case (-5 : -1)
5487 : !
5488 : ! Only few values too many in low part
5489 : !
5490 0 : IF (IFODD) THEN
5491 0 : JHIG = JLOW - INTH + 1
5492 : Else
5493 0 : JHIG = JLOW - INTH + 2
5494 : end if
5495 0 : XHIGT (1) = XLOWT (1)
5496 0 : Do ICRS = 2, JHIG
5497 0 : XWRK = XLOWT (ICRS)
5498 0 : Do IDCR = ICRS - 1, 1, - 1
5499 0 : If (XWRK < XHIGT(IDCR)) Then
5500 0 : XHIGT (IDCR + 1) = XHIGT (IDCR)
5501 : Else
5502 : Exit
5503 : End If
5504 : End Do
5505 0 : XHIGT (IDCR + 1) = XWRK
5506 : End Do
5507 : !
5508 0 : Do ICRS = JHIG + 1, JLOW
5509 0 : If (XLOWT (ICRS) > XHIGT(1)) Then
5510 0 : XWRK = XLOWT (ICRS)
5511 0 : Do IDCR = 2, JHIG
5512 0 : If (XWRK >= XHIGT(IDCR)) Then
5513 0 : XHIGT (IDCR - 1) = XHIGT (IDCR)
5514 : else
5515 : exit
5516 : end if
5517 : End Do
5518 0 : XHIGT (IDCR - 1) = XWRK
5519 : End If
5520 : End Do
5521 : !
5522 0 : IF (IFODD) THEN
5523 0 : median = XHIGT(1)
5524 : Else
5525 0 : median = (XHIGT(1) + XHIGT(2)) / 2
5526 : end if
5527 0 : Return
5528 : !
5529 : !
5530 : Case (: -6)
5531 : !
5532 : ! last case: too many values in low part
5533 : !
5534 :
5535 0 : IMIL = (JLOW + 1) / 2
5536 0 : IFIN = JLOW
5537 : !
5538 : ! One chooses a pivot from 1st, last, and middle values
5539 : !
5540 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
5541 0 : XWRK = XLOWT (1)
5542 0 : XLOWT (1) = XLOWT (IMIL)
5543 0 : XLOWT (IMIL) = XWRK
5544 : End If
5545 0 : If (XLOWT(IMIL) > XLOWT(IFIN)) Then
5546 0 : XWRK = XLOWT (IFIN)
5547 0 : XLOWT (IFIN) = XLOWT (IMIL)
5548 0 : XLOWT (IMIL) = XWRK
5549 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
5550 0 : XWRK = XLOWT (1)
5551 0 : XLOWT (1) = XLOWT (IMIL)
5552 0 : XLOWT (IMIL) = XWRK
5553 : End If
5554 : End If
5555 0 : If (IFIN <= 3) Exit
5556 : !
5557 : XPIV = XLOWT(1) + INT(REAL(INTH, sp) / REAL(JLOW + INTH, sp), i4) * &
5558 0 : (XLOWT(IFIN) - XLOWT(1))
5559 :
5560 : !
5561 : ! One takes values > XPIV to XHIGT
5562 : !
5563 0 : JHIG = 0
5564 0 : JLOW = 0
5565 : !
5566 0 : If (XLOWT(IFIN) > XPIV) Then
5567 : ICRS = 0
5568 : Do
5569 0 : ICRS = ICRS + 1
5570 0 : If (XLOWT(ICRS) > XPIV) Then
5571 0 : JHIG = JHIG + 1
5572 0 : XHIGT (JHIG) = XLOWT (ICRS)
5573 0 : If (ICRS >= IFIN) Exit
5574 : Else
5575 0 : JLOW = JLOW + 1
5576 0 : XLOWT (JLOW) = XLOWT (ICRS)
5577 0 : If (JLOW >= INTH) Exit
5578 : End If
5579 : End Do
5580 : !
5581 0 : If (ICRS < IFIN) Then
5582 : Do
5583 0 : ICRS = ICRS + 1
5584 0 : If (XLOWT(ICRS) <= XPIV) Then
5585 0 : JLOW = JLOW + 1
5586 0 : XLOWT (JLOW) = XLOWT (ICRS)
5587 : Else
5588 0 : If (ICRS >= IFIN) Exit
5589 : End If
5590 : End Do
5591 : End If
5592 : Else
5593 0 : Do ICRS = 1, IFIN
5594 0 : If (XLOWT(ICRS) > XPIV) Then
5595 0 : JHIG = JHIG + 1
5596 0 : XHIGT (JHIG) = XLOWT (ICRS)
5597 : Else
5598 0 : JLOW = JLOW + 1
5599 0 : XLOWT (JLOW) = XLOWT (ICRS)
5600 0 : If (JLOW >= INTH) Exit
5601 : End If
5602 : End Do
5603 : !
5604 0 : Do ICRS = ICRS + 1, IFIN
5605 0 : If (XLOWT(ICRS) <= XPIV) Then
5606 0 : JLOW = JLOW + 1
5607 0 : XLOWT (JLOW) = XLOWT (ICRS)
5608 : End If
5609 : End Do
5610 : End If
5611 : !
5612 : End Select
5613 : !
5614 : End Do
5615 : !
5616 : ! Now, we only need to find maximum of the 1:INTH set
5617 : !
5618 0 : if (IFODD) then
5619 0 : median = MAXVAL (XLOWT (1 : INTH))
5620 : else
5621 0 : XWRK = MAX (XLOWT (1), XLOWT (2))
5622 0 : XWRK1 = MIN (XLOWT (1), XLOWT (2))
5623 0 : DO ICRS = 3, INTH
5624 0 : IF (XLOWT (ICRS) > XWRK1) THEN
5625 0 : IF (XLOWT (ICRS) > XWRK) THEN
5626 : XWRK1 = XWRK
5627 : XWRK = XLOWT (ICRS)
5628 : Else
5629 0 : XWRK1 = XLOWT (ICRS)
5630 : end if
5631 : end if
5632 : ENDDO
5633 0 : median = (XWRK + XWRK1) / 2
5634 : end if
5635 : Return
5636 : !
5637 1 : End Function I_median
5638 :
5639 0 : Subroutine D_mrgref (XVALT, IRNGT)
5640 : ! Ranks array XVALT into index array IRNGT, using merge-sort
5641 : ! __________________________________________________________
5642 : ! This version is not optimized for performance, and is thus
5643 : ! not as difficult to read as some other ones.
5644 : ! Michel Olagnon - April 2000
5645 : ! __________________________________________________________
5646 : ! __________________________________________________________
5647 : real(kind = dp), Dimension (:), Intent (In) :: XVALT
5648 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
5649 : ! __________________________________________________________
5650 : !
5651 0 : Integer(kind = i4), Dimension (:), Allocatable :: JWRKT
5652 : Integer(kind = i4) :: LMTNA, LMTNC
5653 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
5654 : !
5655 0 : NVAL = Min (SIZE(XVALT), SIZE(IRNGT))
5656 0 : If (NVAL <= 0) Then
5657 : Return
5658 : End If
5659 : !
5660 : ! Fill-in the index array, creating ordered couples
5661 : !
5662 0 : Do IIND = 2, NVAL, 2
5663 0 : If (XVALT(IIND - 1) <= XVALT(IIND)) Then
5664 0 : IRNGT (IIND - 1) = IIND - 1
5665 0 : IRNGT (IIND) = IIND
5666 : Else
5667 0 : IRNGT (IIND - 1) = IIND
5668 0 : IRNGT (IIND) = IIND - 1
5669 : End If
5670 : End Do
5671 0 : If (Modulo (NVAL, 2) /= 0) Then
5672 0 : IRNGT (NVAL) = NVAL
5673 : End If
5674 : !
5675 : ! We will now have ordered subsets A - B - A - B - ...
5676 : ! and merge A and B couples into C - C - ...
5677 : !
5678 0 : Allocate (JWRKT(1 : NVAL))
5679 0 : LMTNC = 2
5680 0 : LMTNA = 2
5681 : !
5682 : ! Iteration. Each time, the length of the ordered subsets
5683 : ! is doubled.
5684 : !
5685 0 : Do
5686 0 : If (LMTNA >= NVAL) Exit
5687 0 : IWRKF = 0
5688 0 : LMTNC = 2 * LMTNC
5689 0 : IWRK = 0
5690 : !
5691 : ! Loop on merges of A and B into C
5692 : !
5693 : Do
5694 0 : IINDA = IWRKF
5695 0 : IWRKD = IWRKF + 1
5696 0 : IWRKF = IINDA + LMTNC
5697 0 : JINDA = IINDA + LMTNA
5698 0 : If (IWRKF >= NVAL) Then
5699 0 : If (JINDA >= NVAL) Exit
5700 : IWRKF = NVAL
5701 : End If
5702 0 : IINDB = JINDA
5703 : !
5704 : ! Shortcut for the case when the max of A is smaller
5705 : ! than the min of B (no need to do anything)
5706 : !
5707 0 : If (XVALT(IRNGT(JINDA)) <= XVALT(IRNGT(JINDA + 1))) Then
5708 : IWRK = IWRKF
5709 : Cycle
5710 : End If
5711 : !
5712 : ! One steps in the C subset, that we create in the final rank array
5713 : !
5714 0 : Do
5715 0 : If (IWRK >= IWRKF) Then
5716 : !
5717 : ! Make a copy of the rank array for next iteration
5718 : !
5719 0 : IRNGT (IWRKD : IWRKF) = JWRKT (IWRKD : IWRKF)
5720 : Exit
5721 : End If
5722 : !
5723 0 : IWRK = IWRK + 1
5724 : !
5725 : ! We still have unprocessed values in both A and B
5726 : !
5727 0 : If (IINDA < JINDA) Then
5728 0 : If (IINDB < IWRKF) Then
5729 0 : If (XVALT(IRNGT(IINDA + 1)) > XVALT(IRNGT(IINDB + 1))) &
5730 : & Then
5731 0 : IINDB = IINDB + 1
5732 0 : JWRKT (IWRK) = IRNGT (IINDB)
5733 : Else
5734 0 : IINDA = IINDA + 1
5735 0 : JWRKT (IWRK) = IRNGT (IINDA)
5736 : End If
5737 : Else
5738 : !
5739 : ! Only A still with unprocessed values
5740 : !
5741 0 : IINDA = IINDA + 1
5742 0 : JWRKT (IWRK) = IRNGT (IINDA)
5743 : End If
5744 : Else
5745 : !
5746 : ! Only B still with unprocessed values
5747 : !
5748 0 : IRNGT (IWRKD : IINDB) = JWRKT (IWRKD : IINDB)
5749 : IWRK = IWRKF
5750 : Exit
5751 : End If
5752 : !
5753 : End Do
5754 : End Do
5755 : !
5756 : ! The Cs become As and Bs
5757 : !
5758 0 : LMTNA = 2 * LMTNA
5759 : End Do
5760 : !
5761 : ! Clean up
5762 : !
5763 0 : Deallocate (JWRKT)
5764 0 : Return
5765 : !
5766 0 : End Subroutine D_mrgref
5767 :
5768 0 : Subroutine R_mrgref (XVALT, IRNGT)
5769 : ! Ranks array XVALT into index array IRNGT, using merge-sort
5770 : ! __________________________________________________________
5771 : ! This version is not optimized for performance, and is thus
5772 : ! not as difficult to read as some other ones.
5773 : ! Michel Olagnon - April 2000
5774 : ! __________________________________________________________
5775 : ! _________________________________________________________
5776 : Real(kind = sp), Dimension (:), Intent (In) :: XVALT
5777 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
5778 : ! __________________________________________________________
5779 : !
5780 0 : Integer(kind = i4), Dimension (:), Allocatable :: JWRKT
5781 : Integer(kind = i4) :: LMTNA, LMTNC
5782 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
5783 : !
5784 0 : NVAL = Min (SIZE(XVALT), SIZE(IRNGT))
5785 0 : If (NVAL <= 0) Then
5786 : Return
5787 : End If
5788 : !
5789 : ! Fill-in the index array, creating ordered couples
5790 : !
5791 0 : Do IIND = 2, NVAL, 2
5792 0 : If (XVALT(IIND - 1) <= XVALT(IIND)) Then
5793 0 : IRNGT (IIND - 1) = IIND - 1
5794 0 : IRNGT (IIND) = IIND
5795 : Else
5796 0 : IRNGT (IIND - 1) = IIND
5797 0 : IRNGT (IIND) = IIND - 1
5798 : End If
5799 : End Do
5800 0 : If (Modulo (NVAL, 2) /= 0) Then
5801 0 : IRNGT (NVAL) = NVAL
5802 : End If
5803 : !
5804 : ! We will now have ordered subsets A - B - A - B - ...
5805 : ! and merge A and B couples into C - C - ...
5806 : !
5807 0 : Allocate (JWRKT(1 : NVAL))
5808 0 : LMTNC = 2
5809 0 : LMTNA = 2
5810 : !
5811 : ! Iteration. Each time, the length of the ordered subsets
5812 : ! is doubled.
5813 : !
5814 0 : Do
5815 0 : If (LMTNA >= NVAL) Exit
5816 0 : IWRKF = 0
5817 0 : LMTNC = 2 * LMTNC
5818 0 : IWRK = 0
5819 : !
5820 : ! Loop on merges of A and B into C
5821 : !
5822 : Do
5823 0 : IINDA = IWRKF
5824 0 : IWRKD = IWRKF + 1
5825 0 : IWRKF = IINDA + LMTNC
5826 0 : JINDA = IINDA + LMTNA
5827 0 : If (IWRKF >= NVAL) Then
5828 0 : If (JINDA >= NVAL) Exit
5829 : IWRKF = NVAL
5830 : End If
5831 0 : IINDB = JINDA
5832 : !
5833 : ! Shortcut for the case when the max of A is smaller
5834 : ! than the min of B (no need to do anything)
5835 : !
5836 0 : If (XVALT(IRNGT(JINDA)) <= XVALT(IRNGT(JINDA + 1))) Then
5837 : IWRK = IWRKF
5838 : Cycle
5839 : End If
5840 : !
5841 : ! One steps in the C subset, that we create in the final rank array
5842 : !
5843 0 : Do
5844 0 : If (IWRK >= IWRKF) Then
5845 : !
5846 : ! Make a copy of the rank array for next iteration
5847 : !
5848 0 : IRNGT (IWRKD : IWRKF) = JWRKT (IWRKD : IWRKF)
5849 : Exit
5850 : End If
5851 : !
5852 0 : IWRK = IWRK + 1
5853 : !
5854 : ! We still have unprocessed values in both A and B
5855 : !
5856 0 : If (IINDA < JINDA) Then
5857 0 : If (IINDB < IWRKF) Then
5858 0 : If (XVALT(IRNGT(IINDA + 1)) > XVALT(IRNGT(IINDB + 1))) &
5859 : & Then
5860 0 : IINDB = IINDB + 1
5861 0 : JWRKT (IWRK) = IRNGT (IINDB)
5862 : Else
5863 0 : IINDA = IINDA + 1
5864 0 : JWRKT (IWRK) = IRNGT (IINDA)
5865 : End If
5866 : Else
5867 : !
5868 : ! Only A still with unprocessed values
5869 : !
5870 0 : IINDA = IINDA + 1
5871 0 : JWRKT (IWRK) = IRNGT (IINDA)
5872 : End If
5873 : Else
5874 : !
5875 : ! Only B still with unprocessed values
5876 : !
5877 0 : IRNGT (IWRKD : IINDB) = JWRKT (IWRKD : IINDB)
5878 : IWRK = IWRKF
5879 : Exit
5880 : End If
5881 : !
5882 : End Do
5883 : End Do
5884 : !
5885 : ! The Cs become As and Bs
5886 : !
5887 0 : LMTNA = 2 * LMTNA
5888 : End Do
5889 : !
5890 : ! Clean up
5891 : !
5892 0 : Deallocate (JWRKT)
5893 0 : Return
5894 : !
5895 0 : End Subroutine R_mrgref
5896 :
5897 0 : Subroutine I_mrgref (XVALT, IRNGT)
5898 : ! Ranks array XVALT into index array IRNGT, using merge-sort
5899 : ! __________________________________________________________
5900 : ! This version is not optimized for performance, and is thus
5901 : ! not as difficult to read as some other ones.
5902 : ! Michel Olagnon - April 2000
5903 : ! __________________________________________________________
5904 : ! __________________________________________________________
5905 : Integer(kind = i4), Dimension (:), Intent (In) :: XVALT
5906 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
5907 : ! __________________________________________________________
5908 : !
5909 0 : Integer(kind = i4), Dimension (:), Allocatable :: JWRKT
5910 : Integer(kind = i4) :: LMTNA, LMTNC
5911 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
5912 : !
5913 0 : NVAL = Min (SIZE(XVALT), SIZE(IRNGT))
5914 0 : If (NVAL <= 0) Then
5915 : Return
5916 : End If
5917 : !
5918 : ! Fill-in the index array, creating ordered couples
5919 : !
5920 0 : Do IIND = 2, NVAL, 2
5921 0 : If (XVALT(IIND - 1) <= XVALT(IIND)) Then
5922 0 : IRNGT (IIND - 1) = IIND - 1
5923 0 : IRNGT (IIND) = IIND
5924 : Else
5925 0 : IRNGT (IIND - 1) = IIND
5926 0 : IRNGT (IIND) = IIND - 1
5927 : End If
5928 : End Do
5929 0 : If (Modulo (NVAL, 2) /= 0) Then
5930 0 : IRNGT (NVAL) = NVAL
5931 : End If
5932 : !
5933 : ! We will now have ordered subsets A - B - A - B - ...
5934 : ! and merge A and B couples into C - C - ...
5935 : !
5936 0 : Allocate (JWRKT(1 : NVAL))
5937 0 : LMTNC = 2
5938 0 : LMTNA = 2
5939 : !
5940 : ! Iteration. Each time, the length of the ordered subsets
5941 : ! is doubled.
5942 : !
5943 0 : Do
5944 0 : If (LMTNA >= NVAL) Exit
5945 0 : IWRKF = 0
5946 0 : LMTNC = 2 * LMTNC
5947 0 : IWRK = 0
5948 : !
5949 : ! Loop on merges of A and B into C
5950 : !
5951 : Do
5952 0 : IINDA = IWRKF
5953 0 : IWRKD = IWRKF + 1
5954 0 : IWRKF = IINDA + LMTNC
5955 0 : JINDA = IINDA + LMTNA
5956 0 : If (IWRKF >= NVAL) Then
5957 0 : If (JINDA >= NVAL) Exit
5958 : IWRKF = NVAL
5959 : End If
5960 0 : IINDB = JINDA
5961 : !
5962 : ! Shortcut for the case when the max of A is smaller
5963 : ! than the min of B (no need to do anything)
5964 : !
5965 0 : If (XVALT(IRNGT(JINDA)) <= XVALT(IRNGT(JINDA + 1))) Then
5966 : IWRK = IWRKF
5967 : Cycle
5968 : End If
5969 : !
5970 : ! One steps in the C subset, that we create in the final rank array
5971 : !
5972 0 : Do
5973 0 : If (IWRK >= IWRKF) Then
5974 : !
5975 : ! Make a copy of the rank array for next iteration
5976 : !
5977 0 : IRNGT (IWRKD : IWRKF) = JWRKT (IWRKD : IWRKF)
5978 : Exit
5979 : End If
5980 : !
5981 0 : IWRK = IWRK + 1
5982 : !
5983 : ! We still have unprocessed values in both A and B
5984 : !
5985 0 : If (IINDA < JINDA) Then
5986 0 : If (IINDB < IWRKF) Then
5987 0 : If (XVALT(IRNGT(IINDA + 1)) > XVALT(IRNGT(IINDB + 1))) &
5988 : & Then
5989 0 : IINDB = IINDB + 1
5990 0 : JWRKT (IWRK) = IRNGT (IINDB)
5991 : Else
5992 0 : IINDA = IINDA + 1
5993 0 : JWRKT (IWRK) = IRNGT (IINDA)
5994 : End If
5995 : Else
5996 : !
5997 : ! Only A still with unprocessed values
5998 : !
5999 0 : IINDA = IINDA + 1
6000 0 : JWRKT (IWRK) = IRNGT (IINDA)
6001 : End If
6002 : Else
6003 : !
6004 : ! Only B still with unprocessed values
6005 : !
6006 0 : IRNGT (IWRKD : IINDB) = JWRKT (IWRKD : IINDB)
6007 : IWRK = IWRKF
6008 : Exit
6009 : End If
6010 : !
6011 : End Do
6012 : End Do
6013 : !
6014 : ! The Cs become As and Bs
6015 : !
6016 0 : LMTNA = 2 * LMTNA
6017 : End Do
6018 : !
6019 : ! Clean up
6020 : !
6021 0 : Deallocate (JWRKT)
6022 0 : Return
6023 : !
6024 0 : End Subroutine I_mrgref
6025 :
6026 9010 : Subroutine D_mrgrnk (XDONT, IRNGT)
6027 : ! __________________________________________________________
6028 : ! MRGRNK = Merge-sort ranking of an array
6029 : ! For performance reasons, the first 2 passes are taken
6030 : ! out of the standard loop, and use dedicated coding.
6031 : ! __________________________________________________________
6032 : ! __________________________________________________________
6033 : real(kind = dp), Dimension (:), Intent (In) :: XDONT
6034 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
6035 : ! __________________________________________________________
6036 4505 : real(kind = dp) :: XVALA, XVALB
6037 : !
6038 4505 : Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
6039 : Integer(kind = i4) :: LMTNA, LMTNC, IRNG1, IRNG2
6040 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
6041 : !
6042 4505 : NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
6043 : Select Case (NVAL)
6044 : Case (: 0)
6045 0 : Return
6046 : Case (1)
6047 0 : IRNGT (1) = 1
6048 4505 : Return
6049 : Case Default
6050 :
6051 : End Select
6052 : !
6053 : ! Fill-in the index array, creating ordered couples
6054 : !
6055 135465 : Do IIND = 2, NVAL, 2
6056 135465 : If (XDONT(IIND - 1) <= XDONT(IIND)) Then
6057 128003 : IRNGT (IIND - 1) = IIND - 1
6058 128003 : IRNGT (IIND) = IIND
6059 : Else
6060 2957 : IRNGT (IIND - 1) = IIND
6061 2957 : IRNGT (IIND) = IIND - 1
6062 : End If
6063 : End Do
6064 4505 : If (Modulo(NVAL, 2) /= 0) Then
6065 4452 : IRNGT (NVAL) = NVAL
6066 : End If
6067 : !
6068 : ! We will now have ordered subsets A - B - A - B - ...
6069 : ! and merge A and B couples into C - C - ...
6070 : !
6071 4505 : LMTNA = 2
6072 4505 : LMTNC = 4
6073 : !
6074 : ! First iteration. The length of the ordered subsets goes from 2 to 4
6075 : !
6076 : Do
6077 4505 : If (NVAL <= 2) Exit
6078 : !
6079 : ! Loop on merges of A and B into C
6080 : !
6081 69868 : Do IWRKD = 0, NVAL - 1, 4
6082 69867 : If ((IWRKD + 4) > NVAL) Then
6083 4504 : If ((IWRKD + 2) >= NVAL) Exit
6084 : !
6085 : ! 1 2 3
6086 : !
6087 182 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Exit
6088 : !
6089 : ! 1 3 2
6090 : !
6091 21 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
6092 15 : IRNG2 = IRNGT (IWRKD + 2)
6093 15 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
6094 15 : IRNGT (IWRKD + 3) = IRNG2
6095 : !
6096 : ! 3 1 2
6097 : !
6098 : Else
6099 6 : IRNG1 = IRNGT (IWRKD + 1)
6100 6 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
6101 6 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 2)
6102 6 : IRNGT (IWRKD + 2) = IRNG1
6103 : End If
6104 : If (.true.) Exit ! Exit ! JM
6105 : End If
6106 : !
6107 : ! 1 2 3 4
6108 : !
6109 65363 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Cycle
6110 : !
6111 : ! 1 3 x x
6112 : !
6113 7463 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
6114 879 : IRNG2 = IRNGT (IWRKD + 2)
6115 879 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
6116 879 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
6117 : ! 1 3 2 4
6118 869 : IRNGT (IWRKD + 3) = IRNG2
6119 : Else
6120 : ! 1 3 4 2
6121 10 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
6122 10 : IRNGT (IWRKD + 4) = IRNG2
6123 : End If
6124 : !
6125 : ! 3 x x x
6126 : !
6127 : Else
6128 2100 : IRNG1 = IRNGT (IWRKD + 1)
6129 2100 : IRNG2 = IRNGT (IWRKD + 2)
6130 2100 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
6131 2100 : If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD + 4))) Then
6132 2092 : IRNGT (IWRKD + 2) = IRNG1
6133 2092 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
6134 : ! 3 1 2 4
6135 2090 : IRNGT (IWRKD + 3) = IRNG2
6136 : Else
6137 : ! 3 1 4 2
6138 2 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
6139 2 : IRNGT (IWRKD + 4) = IRNG2
6140 : End If
6141 : Else
6142 : ! 3 4 1 2
6143 8 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 4)
6144 8 : IRNGT (IWRKD + 3) = IRNG1
6145 8 : IRNGT (IWRKD + 4) = IRNG2
6146 : End If
6147 : End If
6148 : End Do
6149 : !
6150 : ! The Cs become As and Bs
6151 : !
6152 : LMTNA = 4
6153 0 : If (.true.) Exit ! Exit ! JM
6154 : End Do
6155 : !
6156 : ! Iteration loop. Each time, the length of the ordered subsets
6157 : ! is doubled.
6158 : !
6159 17477 : Do
6160 21982 : If (LMTNA >= NVAL) Exit
6161 17477 : IWRKF = 0
6162 17477 : LMTNC = 2 * LMTNC
6163 : !
6164 : ! Loop on merges of A and B into C
6165 : !
6166 : Do
6167 82839 : IWRK = IWRKF
6168 82839 : IWRKD = IWRKF + 1
6169 82839 : JINDA = IWRKF + LMTNA
6170 82839 : IWRKF = IWRKF + LMTNC
6171 82839 : If (IWRKF >= NVAL) Then
6172 34914 : If (JINDA >= NVAL) Exit
6173 : IWRKF = NVAL
6174 : End If
6175 65362 : IINDA = 1
6176 65362 : IINDB = JINDA + 1
6177 : !
6178 : ! Shortcut for the case when the max of A is smaller
6179 : ! than the min of B. This line may be activated when the
6180 : ! initial set is already close to sorted.
6181 : !
6182 : ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
6183 : !
6184 : ! One steps in the C subset, that we build in the final rank array
6185 : !
6186 : ! Make a copy of the rank array for the merge iteration
6187 : !
6188 624306 : JWRKT (1 : LMTNA) = IRNGT (IWRKD : JINDA)
6189 : !
6190 65362 : XVALA = XDONT (JWRKT(IINDA))
6191 65362 : XVALB = XDONT (IRNGT(IINDB))
6192 : !
6193 17477 : Do
6194 571262 : IWRK = IWRK + 1
6195 : !
6196 : ! We still have unprocessed values in both A and B
6197 : !
6198 636538 : If (XVALA > XVALB) Then
6199 12557 : IRNGT (IWRK) = IRNGT (IINDB)
6200 12557 : IINDB = IINDB + 1
6201 12557 : If (IINDB > IWRKF) Then
6202 : ! Only A still with unprocessed values
6203 325 : IRNGT (IWRK + 1 : IWRKF) = JWRKT (IINDA : LMTNA)
6204 : Exit
6205 : End If
6206 12471 : XVALB = XDONT (IRNGT(IINDB))
6207 : Else
6208 558705 : IRNGT (IWRK) = JWRKT (IINDA)
6209 558705 : IINDA = IINDA + 1
6210 558705 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
6211 493429 : XVALA = XDONT (JWRKT(IINDA))
6212 : End If
6213 : !
6214 : End Do
6215 : End Do
6216 : !
6217 : ! The Cs become As and Bs
6218 : !
6219 17477 : LMTNA = 2 * LMTNA
6220 : End Do
6221 : !
6222 : Return
6223 : !
6224 0 : End Subroutine D_mrgrnk
6225 :
6226 4 : Subroutine R_mrgrnk (XDONT, IRNGT)
6227 : ! __________________________________________________________
6228 : ! MRGRNK = Merge-sort ranking of an array
6229 : ! For performance reasons, the first 2 passes are taken
6230 : ! out of the standard loop, and use dedicated coding.
6231 : ! __________________________________________________________
6232 : ! _________________________________________________________
6233 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
6234 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
6235 : ! __________________________________________________________
6236 2 : Real(kind = sp) :: XVALA, XVALB
6237 : !
6238 2 : Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
6239 : Integer(kind = i4) :: LMTNA, LMTNC, IRNG1, IRNG2
6240 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
6241 : !
6242 2 : NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
6243 : Select Case (NVAL)
6244 : Case (: 0)
6245 0 : Return
6246 : Case (1)
6247 0 : IRNGT (1) = 1
6248 2 : Return
6249 : Case Default
6250 :
6251 : End Select
6252 : !
6253 : ! Fill-in the index array, creating ordered couples
6254 : !
6255 12 : Do IIND = 2, NVAL, 2
6256 12 : If (XDONT(IIND - 1) <= XDONT(IIND)) Then
6257 0 : IRNGT (IIND - 1) = IIND - 1
6258 0 : IRNGT (IIND) = IIND
6259 : Else
6260 10 : IRNGT (IIND - 1) = IIND
6261 10 : IRNGT (IIND) = IIND - 1
6262 : End If
6263 : End Do
6264 2 : If (Modulo(NVAL, 2) /= 0) Then
6265 0 : IRNGT (NVAL) = NVAL
6266 : End If
6267 : !
6268 : ! We will now have ordered subsets A - B - A - B - ...
6269 : ! and merge A and B couples into C - C - ...
6270 : !
6271 2 : LMTNA = 2
6272 2 : LMTNC = 4
6273 : !
6274 : ! First iteration. The length of the ordered subsets goes from 2 to 4
6275 : !
6276 : Do
6277 2 : If (NVAL <= 2) Exit
6278 : !
6279 : ! Loop on merges of A and B into C
6280 : !
6281 6 : Do IWRKD = 0, NVAL - 1, 4
6282 6 : If ((IWRKD + 4) > NVAL) Then
6283 2 : If ((IWRKD + 2) >= NVAL) Exit
6284 : !
6285 : ! 1 2 3
6286 : !
6287 0 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Exit
6288 : !
6289 : ! 1 3 2
6290 : !
6291 0 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
6292 0 : IRNG2 = IRNGT (IWRKD + 2)
6293 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
6294 0 : IRNGT (IWRKD + 3) = IRNG2
6295 : !
6296 : ! 3 1 2
6297 : !
6298 : Else
6299 0 : IRNG1 = IRNGT (IWRKD + 1)
6300 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
6301 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 2)
6302 0 : IRNGT (IWRKD + 2) = IRNG1
6303 : End If
6304 : If (.true.) Exit ! Exit ! JM
6305 : End If
6306 : !
6307 : ! 1 2 3 4
6308 : !
6309 4 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Cycle
6310 : !
6311 : ! 1 3 x x
6312 : !
6313 6 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
6314 0 : IRNG2 = IRNGT (IWRKD + 2)
6315 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
6316 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
6317 : ! 1 3 2 4
6318 0 : IRNGT (IWRKD + 3) = IRNG2
6319 : Else
6320 : ! 1 3 4 2
6321 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
6322 0 : IRNGT (IWRKD + 4) = IRNG2
6323 : End If
6324 : !
6325 : ! 3 x x x
6326 : !
6327 : Else
6328 4 : IRNG1 = IRNGT (IWRKD + 1)
6329 4 : IRNG2 = IRNGT (IWRKD + 2)
6330 4 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
6331 4 : If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD + 4))) Then
6332 0 : IRNGT (IWRKD + 2) = IRNG1
6333 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
6334 : ! 3 1 2 4
6335 0 : IRNGT (IWRKD + 3) = IRNG2
6336 : Else
6337 : ! 3 1 4 2
6338 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
6339 0 : IRNGT (IWRKD + 4) = IRNG2
6340 : End If
6341 : Else
6342 : ! 3 4 1 2
6343 4 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 4)
6344 4 : IRNGT (IWRKD + 3) = IRNG1
6345 4 : IRNGT (IWRKD + 4) = IRNG2
6346 : End If
6347 : End If
6348 : End Do
6349 : !
6350 : ! The Cs become As and Bs
6351 : !
6352 : LMTNA = 4
6353 0 : If (.true.) Exit ! Exit ! JM
6354 : End Do
6355 : !
6356 : ! Iteration loop. Each time, the length of the ordered subsets
6357 : ! is doubled.
6358 : !
6359 4 : Do
6360 6 : If (LMTNA >= NVAL) Exit
6361 4 : IWRKF = 0
6362 4 : LMTNC = 2 * LMTNC
6363 : !
6364 : ! Loop on merges of A and B into C
6365 : !
6366 : Do
6367 8 : IWRK = IWRKF
6368 8 : IWRKD = IWRKF + 1
6369 8 : JINDA = IWRKF + LMTNA
6370 8 : IWRKF = IWRKF + LMTNC
6371 8 : If (IWRKF >= NVAL) Then
6372 6 : If (JINDA >= NVAL) Exit
6373 : IWRKF = NVAL
6374 : End If
6375 4 : IINDA = 1
6376 4 : IINDB = JINDA + 1
6377 : !
6378 : ! Shortcut for the case when the max of A is smaller
6379 : ! than the min of B. This line may be activated when the
6380 : ! initial set is already close to sorted.
6381 : !
6382 : ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
6383 : !
6384 : ! One steps in the C subset, that we build in the final rank array
6385 : !
6386 : ! Make a copy of the rank array for the merge iteration
6387 : !
6388 28 : JWRKT (1 : LMTNA) = IRNGT (IWRKD : JINDA)
6389 : !
6390 4 : XVALA = XDONT (JWRKT(IINDA))
6391 4 : XVALB = XDONT (IRNGT(IINDB))
6392 : !
6393 4 : Do
6394 12 : IWRK = IWRK + 1
6395 : !
6396 : ! We still have unprocessed values in both A and B
6397 : !
6398 12 : If (XVALA > XVALB) Then
6399 12 : IRNGT (IWRK) = IRNGT (IINDB)
6400 12 : IINDB = IINDB + 1
6401 12 : If (IINDB > IWRKF) Then
6402 : ! Only A still with unprocessed values
6403 28 : IRNGT (IWRK + 1 : IWRKF) = JWRKT (IINDA : LMTNA)
6404 : Exit
6405 : End If
6406 8 : XVALB = XDONT (IRNGT(IINDB))
6407 : Else
6408 0 : IRNGT (IWRK) = JWRKT (IINDA)
6409 0 : IINDA = IINDA + 1
6410 0 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
6411 0 : XVALA = XDONT (JWRKT(IINDA))
6412 : End If
6413 : !
6414 : End Do
6415 : End Do
6416 : !
6417 : ! The Cs become As and Bs
6418 : !
6419 4 : LMTNA = 2 * LMTNA
6420 : End Do
6421 : !
6422 : Return
6423 : !
6424 4505 : End Subroutine R_mrgrnk
6425 :
6426 0 : Subroutine I_mrgrnk (XDONT, IRNGT)
6427 : ! __________________________________________________________
6428 : ! MRGRNK = Merge-sort ranking of an array
6429 : ! For performance reasons, the first 2 passes are taken
6430 : ! out of the standard loop, and use dedicated coding.
6431 : ! __________________________________________________________
6432 : ! __________________________________________________________
6433 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
6434 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
6435 : ! __________________________________________________________
6436 : Integer(kind = i4) :: XVALA, XVALB
6437 : !
6438 0 : Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
6439 : Integer(kind = i4) :: LMTNA, LMTNC, IRNG1, IRNG2
6440 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
6441 : !
6442 0 : NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
6443 : Select Case (NVAL)
6444 : Case (: 0)
6445 0 : Return
6446 : Case (1)
6447 0 : IRNGT (1) = 1
6448 0 : Return
6449 : Case Default
6450 :
6451 : End Select
6452 : !
6453 : ! Fill-in the index array, creating ordered couples
6454 : !
6455 0 : Do IIND = 2, NVAL, 2
6456 0 : If (XDONT(IIND - 1) <= XDONT(IIND)) Then
6457 0 : IRNGT (IIND - 1) = IIND - 1
6458 0 : IRNGT (IIND) = IIND
6459 : Else
6460 0 : IRNGT (IIND - 1) = IIND
6461 0 : IRNGT (IIND) = IIND - 1
6462 : End If
6463 : End Do
6464 0 : If (Modulo(NVAL, 2) /= 0) Then
6465 0 : IRNGT (NVAL) = NVAL
6466 : End If
6467 : !
6468 : ! We will now have ordered subsets A - B - A - B - ...
6469 : ! and merge A and B couples into C - C - ...
6470 : !
6471 0 : LMTNA = 2
6472 0 : LMTNC = 4
6473 : !
6474 : ! First iteration. The length of the ordered subsets goes from 2 to 4
6475 : !
6476 : Do
6477 0 : If (NVAL <= 2) Exit
6478 : !
6479 : ! Loop on merges of A and B into C
6480 : !
6481 0 : Do IWRKD = 0, NVAL - 1, 4
6482 0 : If ((IWRKD + 4) > NVAL) Then
6483 0 : If ((IWRKD + 2) >= NVAL) Exit
6484 : !
6485 : ! 1 2 3
6486 : !
6487 0 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Exit
6488 : !
6489 : ! 1 3 2
6490 : !
6491 0 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
6492 0 : IRNG2 = IRNGT (IWRKD + 2)
6493 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
6494 0 : IRNGT (IWRKD + 3) = IRNG2
6495 : !
6496 : ! 3 1 2
6497 : !
6498 : Else
6499 0 : IRNG1 = IRNGT (IWRKD + 1)
6500 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
6501 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 2)
6502 0 : IRNGT (IWRKD + 2) = IRNG1
6503 : End If
6504 : If (.true.) Exit ! Exit ! JM
6505 : End If
6506 : !
6507 : ! 1 2 3 4
6508 : !
6509 0 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Cycle
6510 : !
6511 : ! 1 3 x x
6512 : !
6513 0 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
6514 0 : IRNG2 = IRNGT (IWRKD + 2)
6515 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
6516 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
6517 : ! 1 3 2 4
6518 0 : IRNGT (IWRKD + 3) = IRNG2
6519 : Else
6520 : ! 1 3 4 2
6521 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
6522 0 : IRNGT (IWRKD + 4) = IRNG2
6523 : End If
6524 : !
6525 : ! 3 x x x
6526 : !
6527 : Else
6528 0 : IRNG1 = IRNGT (IWRKD + 1)
6529 0 : IRNG2 = IRNGT (IWRKD + 2)
6530 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
6531 0 : If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD + 4))) Then
6532 0 : IRNGT (IWRKD + 2) = IRNG1
6533 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
6534 : ! 3 1 2 4
6535 0 : IRNGT (IWRKD + 3) = IRNG2
6536 : Else
6537 : ! 3 1 4 2
6538 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
6539 0 : IRNGT (IWRKD + 4) = IRNG2
6540 : End If
6541 : Else
6542 : ! 3 4 1 2
6543 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 4)
6544 0 : IRNGT (IWRKD + 3) = IRNG1
6545 0 : IRNGT (IWRKD + 4) = IRNG2
6546 : End If
6547 : End If
6548 : End Do
6549 : !
6550 : ! The Cs become As and Bs
6551 : !
6552 : LMTNA = 4
6553 0 : If (.true.) Exit ! Exit ! JM
6554 : End Do
6555 : !
6556 : ! Iteration loop. Each time, the length of the ordered subsets
6557 : ! is doubled.
6558 : !
6559 0 : Do
6560 0 : If (LMTNA >= NVAL) Exit
6561 0 : IWRKF = 0
6562 0 : LMTNC = 2 * LMTNC
6563 : !
6564 : ! Loop on merges of A and B into C
6565 : !
6566 : Do
6567 0 : IWRK = IWRKF
6568 0 : IWRKD = IWRKF + 1
6569 0 : JINDA = IWRKF + LMTNA
6570 0 : IWRKF = IWRKF + LMTNC
6571 0 : If (IWRKF >= NVAL) Then
6572 0 : If (JINDA >= NVAL) Exit
6573 : IWRKF = NVAL
6574 : End If
6575 0 : IINDA = 1
6576 0 : IINDB = JINDA + 1
6577 : !
6578 : ! Shortcut for the case when the max of A is smaller
6579 : ! than the min of B. This line may be activated when the
6580 : ! initial set is already close to sorted.
6581 : !
6582 : ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
6583 : !
6584 : ! One steps in the C subset, that we build in the final rank array
6585 : !
6586 : ! Make a copy of the rank array for the merge iteration
6587 : !
6588 0 : JWRKT (1 : LMTNA) = IRNGT (IWRKD : JINDA)
6589 : !
6590 0 : XVALA = XDONT (JWRKT(IINDA))
6591 0 : XVALB = XDONT (IRNGT(IINDB))
6592 : !
6593 0 : Do
6594 0 : IWRK = IWRK + 1
6595 : !
6596 : ! We still have unprocessed values in both A and B
6597 : !
6598 0 : If (XVALA > XVALB) Then
6599 0 : IRNGT (IWRK) = IRNGT (IINDB)
6600 0 : IINDB = IINDB + 1
6601 0 : If (IINDB > IWRKF) Then
6602 : ! Only A still with unprocessed values
6603 0 : IRNGT (IWRK + 1 : IWRKF) = JWRKT (IINDA : LMTNA)
6604 : Exit
6605 : End If
6606 0 : XVALB = XDONT (IRNGT(IINDB))
6607 : Else
6608 0 : IRNGT (IWRK) = JWRKT (IINDA)
6609 0 : IINDA = IINDA + 1
6610 0 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
6611 0 : XVALA = XDONT (JWRKT(IINDA))
6612 : End If
6613 : !
6614 : End Do
6615 : End Do
6616 : !
6617 : ! The Cs become As and Bs
6618 : !
6619 0 : LMTNA = 2 * LMTNA
6620 : End Do
6621 : !
6622 : Return
6623 : !
6624 2 : End Subroutine I_mrgrnk
6625 :
6626 0 : Subroutine C_mrgrnk (XDONT, IRNGT)
6627 : ! __________________________________________________________
6628 : ! MRGRNK = Merge-sort ranking of an array
6629 : ! For performance reasons, the first 2 passes are taken
6630 : ! out of the standard loop, and use dedicated coding.
6631 : ! __________________________________________________________
6632 : ! __________________________________________________________
6633 : character(*), Dimension (:), Intent (In) :: XDONT
6634 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
6635 : ! __________________________________________________________
6636 0 : character(len(XDONT)) :: XVALA, XVALB
6637 : !
6638 0 : Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
6639 : Integer(kind = i4) :: LMTNA, LMTNC, IRNG1, IRNG2
6640 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
6641 : !
6642 0 : NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
6643 : Select Case (NVAL)
6644 : Case (: 0)
6645 0 : Return
6646 : Case (1)
6647 0 : IRNGT (1) = 1
6648 0 : Return
6649 : Case Default
6650 :
6651 : End Select
6652 : !
6653 : ! Fill-in the index array, creating ordered couples
6654 : !
6655 0 : Do IIND = 2, NVAL, 2
6656 0 : If (XDONT(IIND - 1) <= XDONT(IIND)) Then
6657 0 : IRNGT (IIND - 1) = IIND - 1
6658 0 : IRNGT (IIND) = IIND
6659 : Else
6660 0 : IRNGT (IIND - 1) = IIND
6661 0 : IRNGT (IIND) = IIND - 1
6662 : End If
6663 : End Do
6664 0 : If (Modulo(NVAL, 2) /= 0) Then
6665 0 : IRNGT (NVAL) = NVAL
6666 : End If
6667 : !
6668 : ! We will now have ordered subsets A - B - A - B - ...
6669 : ! and merge A and B couples into C - C - ...
6670 : !
6671 0 : LMTNA = 2
6672 0 : LMTNC = 4
6673 : !
6674 : ! First iteration. The length of the ordered subsets goes from 2 to 4
6675 : !
6676 : Do
6677 0 : If (NVAL <= 2) Exit
6678 : !
6679 : ! Loop on merges of A and B into C
6680 : !
6681 0 : Do IWRKD = 0, NVAL - 1, 4
6682 0 : If ((IWRKD + 4) > NVAL) Then
6683 0 : If ((IWRKD + 2) >= NVAL) Exit
6684 : !
6685 : ! 1 2 3
6686 : !
6687 0 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Exit
6688 : !
6689 : ! 1 3 2
6690 : !
6691 0 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
6692 0 : IRNG2 = IRNGT (IWRKD + 2)
6693 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
6694 0 : IRNGT (IWRKD + 3) = IRNG2
6695 : !
6696 : ! 3 1 2
6697 : !
6698 : Else
6699 0 : IRNG1 = IRNGT (IWRKD + 1)
6700 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
6701 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 2)
6702 0 : IRNGT (IWRKD + 2) = IRNG1
6703 : End If
6704 : If (.true.) Exit ! Exit ! JM
6705 : End If
6706 : !
6707 : ! 1 2 3 4
6708 : !
6709 0 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Cycle
6710 : !
6711 : ! 1 3 x x
6712 : !
6713 0 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
6714 0 : IRNG2 = IRNGT (IWRKD + 2)
6715 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
6716 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
6717 : ! 1 3 2 4
6718 0 : IRNGT (IWRKD + 3) = IRNG2
6719 : Else
6720 : ! 1 3 4 2
6721 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
6722 0 : IRNGT (IWRKD + 4) = IRNG2
6723 : End If
6724 : !
6725 : ! 3 x x x
6726 : !
6727 : Else
6728 0 : IRNG1 = IRNGT (IWRKD + 1)
6729 0 : IRNG2 = IRNGT (IWRKD + 2)
6730 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
6731 0 : If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD + 4))) Then
6732 0 : IRNGT (IWRKD + 2) = IRNG1
6733 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
6734 : ! 3 1 2 4
6735 0 : IRNGT (IWRKD + 3) = IRNG2
6736 : Else
6737 : ! 3 1 4 2
6738 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
6739 0 : IRNGT (IWRKD + 4) = IRNG2
6740 : End If
6741 : Else
6742 : ! 3 4 1 2
6743 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 4)
6744 0 : IRNGT (IWRKD + 3) = IRNG1
6745 0 : IRNGT (IWRKD + 4) = IRNG2
6746 : End If
6747 : End If
6748 : End Do
6749 : !
6750 : ! The Cs become As and Bs
6751 : !
6752 : LMTNA = 4
6753 0 : If (.true.) Exit ! Exit ! JM
6754 : End Do
6755 : !
6756 : ! Iteration loop. Each time, the length of the ordered subsets
6757 : ! is doubled.
6758 : !
6759 0 : Do
6760 0 : If (LMTNA >= NVAL) Exit
6761 0 : IWRKF = 0
6762 0 : LMTNC = 2 * LMTNC
6763 : !
6764 : ! Loop on merges of A and B into C
6765 : !
6766 : Do
6767 0 : IWRK = IWRKF
6768 0 : IWRKD = IWRKF + 1
6769 0 : JINDA = IWRKF + LMTNA
6770 0 : IWRKF = IWRKF + LMTNC
6771 0 : If (IWRKF >= NVAL) Then
6772 0 : If (JINDA >= NVAL) Exit
6773 : IWRKF = NVAL
6774 : End If
6775 0 : IINDA = 1
6776 0 : IINDB = JINDA + 1
6777 : !
6778 : ! Shortcut for the case when the max of A is smaller
6779 : ! than the min of B. This line may be activated when the
6780 : ! initial set is already close to sorted.
6781 : !
6782 : ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
6783 : !
6784 : ! One steps in the C subset, that we build in the final rank array
6785 : !
6786 : ! Make a copy of the rank array for the merge iteration
6787 : !
6788 0 : JWRKT (1 : LMTNA) = IRNGT (IWRKD : JINDA)
6789 : !
6790 0 : XVALA = XDONT (JWRKT(IINDA))
6791 0 : XVALB = XDONT (IRNGT(IINDB))
6792 : !
6793 0 : Do
6794 0 : IWRK = IWRK + 1
6795 : !
6796 : ! We still have unprocessed values in both A and B
6797 : !
6798 0 : If (XVALA > XVALB) Then
6799 0 : IRNGT (IWRK) = IRNGT (IINDB)
6800 0 : IINDB = IINDB + 1
6801 0 : If (IINDB > IWRKF) Then
6802 : ! Only A still with unprocessed values
6803 0 : IRNGT (IWRK + 1 : IWRKF) = JWRKT (IINDA : LMTNA)
6804 : Exit
6805 : End If
6806 0 : XVALB = XDONT (IRNGT(IINDB))
6807 : Else
6808 0 : IRNGT (IWRK) = JWRKT (IINDA)
6809 0 : IINDA = IINDA + 1
6810 0 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
6811 0 : XVALA = XDONT (JWRKT(IINDA))
6812 : End If
6813 : !
6814 : End Do
6815 : End Do
6816 : !
6817 : ! The Cs become As and Bs
6818 : !
6819 0 : LMTNA = 2 * LMTNA
6820 : End Do
6821 : !
6822 : Return
6823 : !
6824 0 : End Subroutine C_mrgrnk
6825 :
6826 0 : Subroutine D_mulcnt (XDONT, IMULT)
6827 : ! MULCNT = Give for each array value its multiplicity
6828 : ! (number of times that it appears in the array)
6829 : ! __________________________________________________________
6830 : ! Michel Olagnon - Mar. 2000
6831 : ! __________________________________________________________
6832 : ! __________________________________________________________
6833 : real(kind = dp), Dimension (:), Intent (In) :: XDONT
6834 : Integer(kind = i4), Dimension (:), Intent (Out) :: IMULT
6835 : ! __________________________________________________________
6836 : !
6837 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
6838 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: ICNTT
6839 : Integer(kind = i4) :: ICRS
6840 : ! __________________________________________________________
6841 0 : Call UNIINV (XDONT, IWRKT)
6842 0 : ICNTT = 0
6843 0 : Do ICRS = 1, Size(XDONT)
6844 0 : ICNTT(IWRKT(ICRS)) = ICNTT(IWRKT(ICRS)) + 1
6845 : End Do
6846 0 : Do ICRS = 1, Size(XDONT)
6847 0 : IMULT(ICRS) = ICNTT(IWRKT(ICRS))
6848 : End Do
6849 :
6850 : !
6851 0 : End Subroutine D_mulcnt
6852 :
6853 0 : Subroutine R_mulcnt (XDONT, IMULT)
6854 : ! MULCNT = Give for each array value its multiplicity
6855 : ! (number of times that it appears in the array)
6856 : ! __________________________________________________________
6857 : ! Michel Olagnon - Mar. 2000
6858 : ! __________________________________________________________
6859 : ! _________________________________________________________
6860 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
6861 : Integer(kind = i4), Dimension (:), Intent (Out) :: IMULT
6862 : ! __________________________________________________________
6863 : !
6864 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
6865 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: ICNTT
6866 : Integer(kind = i4) :: ICRS
6867 : ! __________________________________________________________
6868 0 : Call UNIINV (XDONT, IWRKT)
6869 0 : ICNTT = 0
6870 0 : Do ICRS = 1, Size(XDONT)
6871 0 : ICNTT(IWRKT(ICRS)) = ICNTT(IWRKT(ICRS)) + 1
6872 : End Do
6873 0 : Do ICRS = 1, Size(XDONT)
6874 0 : IMULT(ICRS) = ICNTT(IWRKT(ICRS))
6875 : End Do
6876 :
6877 : !
6878 0 : End Subroutine R_mulcnt
6879 :
6880 0 : Subroutine I_mulcnt (XDONT, IMULT)
6881 : ! MULCNT = Give for each array value its multiplicity
6882 : ! (number of times that it appears in the array)
6883 : ! __________________________________________________________
6884 : ! Michel Olagnon - Mar. 2000
6885 : ! __________________________________________________________
6886 : ! __________________________________________________________
6887 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
6888 : Integer(kind = i4), Dimension (:), Intent (Out) :: IMULT
6889 : ! __________________________________________________________
6890 : !
6891 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
6892 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: ICNTT
6893 : Integer(kind = i4) :: ICRS
6894 : ! __________________________________________________________
6895 0 : Call UNIINV (XDONT, IWRKT)
6896 0 : ICNTT = 0
6897 0 : Do ICRS = 1, Size(XDONT)
6898 0 : ICNTT(IWRKT(ICRS)) = ICNTT(IWRKT(ICRS)) + 1
6899 : End Do
6900 0 : Do ICRS = 1, Size(XDONT)
6901 0 : IMULT(ICRS) = ICNTT(IWRKT(ICRS))
6902 : End Do
6903 :
6904 : !
6905 0 : End Subroutine I_mulcnt
6906 :
6907 0 : Subroutine D_rapknr (XDONT, IRNGT, NORD)
6908 : ! Ranks partially XDONT by IRNGT, up to order NORD, in decreasing order.
6909 : ! rapknr = (rnkpar backwards)
6910 : ! __________________________________________________________
6911 : ! This routine uses a pivoting strategy such as the one of
6912 : ! finding the median based on the quicksort algorithm, but
6913 : ! we skew the pivot choice to try to bring it to NORD as
6914 : ! fast as possible. It uses 2 temporary arrays, where it
6915 : ! stores the indices of the values larger than the pivot
6916 : ! (IHIGT), and the indices of values smaller than the pivot
6917 : ! that we might still need later on (ILOWT). It iterates
6918 : ! until it can bring the number of values in IHIGT to
6919 : ! exactly NORD, and then uses an insertion sort to rank
6920 : ! this set, since it is supposedly small.
6921 : ! Michel Olagnon - Feb. 2011
6922 : ! __________________________________________________________
6923 : ! __________________________________________________________
6924 : real(kind = dp), Dimension (:), Intent (In) :: XDONT
6925 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
6926 : Integer(kind = i4), Intent (In) :: NORD
6927 : ! __________________________________________________________
6928 0 : real(kind = dp) :: XPIV, XPIV0, XWRK, XWRK1, XMIN, XMAX
6929 : !
6930 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
6931 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
6932 : Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
6933 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
6934 : !
6935 0 : NDON = SIZE (XDONT)
6936 : !
6937 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
6938 : !
6939 0 : If (NDON < 2) Then
6940 0 : If (NORD >= 1) IRNGT (1) = 1
6941 0 : Return
6942 : End If
6943 : !
6944 : ! One chooses a pivot, best estimate possible to put fractile near
6945 : ! mid-point of the set of high values.
6946 : !
6947 0 : If (XDONT(2) < XDONT(1)) Then
6948 0 : ILOWT (1) = 2
6949 0 : IHIGT (1) = 1
6950 : Else
6951 0 : ILOWT (1) = 1
6952 0 : IHIGT (1) = 2
6953 : End If
6954 : !
6955 0 : If (NDON < 3) Then
6956 0 : If (NORD >= 1) IRNGT (1) = IHIGT (1)
6957 0 : If (NORD >= 2) IRNGT (2) = ILOWT (1)
6958 0 : Return
6959 : End If
6960 : ! ---
6961 0 : If (XDONT(3) > XDONT(ILOWT(1))) Then
6962 0 : ILOWT (2) = ILOWT (1)
6963 0 : If (XDONT(3) > XDONT(IHIGT(1))) Then
6964 0 : ILOWT (1) = IHIGT (1)
6965 0 : IHIGT (1) = 3
6966 : Else
6967 0 : ILOWT (1) = 3
6968 : End If
6969 : Else
6970 0 : ILOWT (2) = 3
6971 : End If
6972 : ! ---
6973 0 : If (NDON < 4) Then
6974 0 : If (NORD >= 1) IRNGT (1) = IHIGT (1)
6975 0 : If (NORD >= 2) IRNGT (2) = ILOWT (1)
6976 0 : If (NORD >= 3) IRNGT (3) = ILOWT (2)
6977 0 : Return
6978 : End If
6979 : !
6980 0 : If (XDONT(NDON) > XDONT(ILOWT(1))) Then
6981 0 : ILOWT (3) = ILOWT (2)
6982 0 : ILOWT (2) = ILOWT (1)
6983 0 : If (XDONT(NDON) > XDONT(IHIGT(1))) Then
6984 0 : ILOWT (1) = IHIGT (1)
6985 0 : IHIGT (1) = NDON
6986 : Else
6987 0 : ILOWT (1) = NDON
6988 : End If
6989 : Else
6990 0 : if (XDONT (NDON) > XDONT (ILOWT(2))) Then
6991 0 : ILOWT (3) = ILOWT (2)
6992 0 : ILOWT (2) = NDON
6993 : else
6994 0 : ILOWT (3) = NDON
6995 : end if
6996 : End If
6997 : !
6998 0 : If (NDON < 5) Then
6999 0 : If (NORD >= 1) IRNGT (1) = IHIGT (1)
7000 0 : If (NORD >= 2) IRNGT (2) = ILOWT (1)
7001 0 : If (NORD >= 3) IRNGT (3) = ILOWT (2)
7002 0 : If (NORD >= 4) IRNGT (4) = ILOWT (3)
7003 0 : Return
7004 : End If
7005 : ! ---
7006 0 : JDEB = 0
7007 0 : IDEB = JDEB + 1
7008 0 : JHIG = IDEB
7009 0 : JLOW = 3
7010 0 : XPIV = XDONT (IHIGT(IDEB)) + REAL(2 * NORD, dp) / REAL(NDON + NORD, dp) * &
7011 0 : (XDONT(ILOWT(3)) - XDONT(IHIGT(IDEB)))
7012 0 : If (XPIV >= XDONT(ILOWT(1))) Then
7013 : XPIV = XDONT (IHIGT(IDEB)) + REAL(2 * NORD, dp) / REAL(NDON + NORD, dp) * &
7014 0 : (XDONT(ILOWT(2)) - XDONT(IHIGT(IDEB)))
7015 0 : If (XPIV >= XDONT(ILOWT(1))) &
7016 : XPIV = XDONT (IHIGT(IDEB)) + REAL(2 * NORD, dp) / REAL(NDON + NORD, dp) * &
7017 0 : (XDONT(ILOWT(1)) - XDONT(IHIGT(IDEB)))
7018 : End If
7019 0 : XPIV0 = XPIV
7020 : ! ---
7021 : ! One puts values < pivot in the end and those >= pivot
7022 : ! at the beginning. This is split in 2 cases, so that
7023 : ! we can skip the loop test a number of times.
7024 : ! As we are also filling in the work arrays at the same time
7025 : ! we stop filling in the ILOWT array as soon as we have more
7026 : ! than enough values in IHIGT.
7027 : !
7028 : !
7029 0 : If (XDONT(NDON) < XPIV) Then
7030 : ICRS = 3
7031 : Do
7032 0 : ICRS = ICRS + 1
7033 0 : If (XDONT(ICRS) < XPIV) Then
7034 0 : If (ICRS >= NDON) Exit
7035 0 : JLOW = JLOW + 1
7036 0 : ILOWT (JLOW) = ICRS
7037 : Else
7038 0 : JHIG = JHIG + 1
7039 0 : IHIGT (JHIG) = ICRS
7040 0 : If (JHIG >= NORD) Exit
7041 : End If
7042 : End Do
7043 : !
7044 : ! One restricts further processing because it is no use
7045 : ! to store more low values
7046 : !
7047 0 : If (ICRS < NDON - 1) Then
7048 : Do
7049 0 : ICRS = ICRS + 1
7050 0 : If (XDONT(ICRS) >= XPIV) Then
7051 0 : JHIG = JHIG + 1
7052 0 : IHIGT (JHIG) = ICRS
7053 0 : Else If (ICRS >= NDON) Then
7054 : Exit
7055 : End If
7056 : End Do
7057 : End If
7058 : !
7059 : ! ---
7060 : Else
7061 : !
7062 : ! Same as above, but this is not as easy to optimize, so the
7063 : ! DO-loop is kept
7064 : !
7065 0 : Do ICRS = 4, NDON - 1
7066 0 : If (XDONT(ICRS) < XPIV) Then
7067 0 : JLOW = JLOW + 1
7068 0 : ILOWT (JLOW) = ICRS
7069 : Else
7070 0 : JHIG = JHIG + 1
7071 0 : IHIGT (JHIG) = ICRS
7072 0 : If (JHIG >= NORD) Exit
7073 : End If
7074 : End Do
7075 : !
7076 0 : If (ICRS < NDON - 1) Then
7077 : Do
7078 0 : ICRS = ICRS + 1
7079 0 : If (XDONT(ICRS) >= XPIV) Then
7080 0 : If (ICRS >= NDON) Exit
7081 0 : JHIG = JHIG + 1
7082 0 : IHIGT (JHIG) = ICRS
7083 : End If
7084 : End Do
7085 : End If
7086 : End If
7087 : ! ---
7088 : JLM2 = 0
7089 : JLM1 = 0
7090 : JHM2 = 0
7091 : JHM1 = 0
7092 : Do
7093 0 : if (JHIG == NORD) Exit
7094 0 : If (JHM2 == JHIG .And. JLM2 == JLOW) Then
7095 : !
7096 : ! We are oscillating. Perturbate by bringing JHIG closer by one
7097 : ! to NORD
7098 : !
7099 0 : If (NORD > JHIG) Then
7100 0 : XMAX = XDONT (ILOWT(1))
7101 0 : ILOW = 1
7102 0 : Do ICRS = 2, JLOW
7103 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
7104 0 : XMAX = XDONT (ILOWT(ICRS))
7105 0 : ILOW = ICRS
7106 : End If
7107 : End Do
7108 : !
7109 0 : JHIG = JHIG + 1
7110 0 : IHIGT (JHIG) = ILOWT (ILOW)
7111 0 : ILOWT (ILOW) = ILOWT (JLOW)
7112 0 : JLOW = JLOW - 1
7113 : Else
7114 0 : IHIG = IHIGT (JHIG)
7115 0 : XMIN = XDONT (IHIG)
7116 0 : Do ICRS = 1, JHIG
7117 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
7118 0 : IWRK = IHIGT (ICRS)
7119 0 : XMIN = XDONT (IWRK)
7120 0 : IHIGT (ICRS) = IHIG
7121 0 : IHIG = IWRK
7122 : End If
7123 : End Do
7124 0 : JHIG = JHIG - 1
7125 : End If
7126 : End If
7127 0 : JLM2 = JLM1
7128 0 : JLM1 = JLOW
7129 0 : JHM2 = JHM1
7130 0 : JHM1 = JHIG
7131 : ! ---
7132 : ! We try to bring the number of values in the high values set
7133 : ! closer to NORD.
7134 : !
7135 0 : Select Case (NORD - JHIG)
7136 : Case (2 :)
7137 : !
7138 : ! Not enough values in low part, at least 2 are missing
7139 : !
7140 : Select Case (JLOW)
7141 : !!!!! CASE DEFAULT
7142 : !!!!! write (*,*) "Assertion failed"
7143 : !!!!! STOP
7144 : !
7145 : ! We make a special case when we have so few values in
7146 : ! the low values set that it is bad performance to choose a pivot
7147 : ! and apply the general algorithm.
7148 : !
7149 : Case (2)
7150 0 : If (XDONT(ILOWT(1)) >= XDONT(ILOWT(2))) Then
7151 0 : JHIG = JHIG + 1
7152 0 : IHIGT (JHIG) = ILOWT (1)
7153 0 : JHIG = JHIG + 1
7154 0 : IHIGT (JHIG) = ILOWT (2)
7155 : Else
7156 0 : JHIG = JHIG + 1
7157 0 : IHIGT (JHIG) = ILOWT (2)
7158 0 : JHIG = JHIG + 1
7159 0 : IHIGT (JHIG) = ILOWT (1)
7160 : End If
7161 : Exit
7162 : ! ---
7163 : Case (3)
7164 : !
7165 : !
7166 0 : IWRK1 = ILOWT (1)
7167 0 : IWRK2 = ILOWT (2)
7168 0 : IWRK3 = ILOWT (3)
7169 0 : If (XDONT(IWRK2) > XDONT(IWRK1)) Then
7170 0 : ILOWT (1) = IWRK2
7171 0 : ILOWT (2) = IWRK1
7172 0 : IWRK2 = IWRK1
7173 : End If
7174 0 : If (XDONT(IWRK2) < XDONT(IWRK3)) Then
7175 0 : ILOWT (3) = IWRK2
7176 0 : ILOWT (2) = IWRK3
7177 0 : IWRK2 = IWRK3
7178 0 : If (XDONT(IWRK2) > XDONT(ILOWT(1))) Then
7179 0 : ILOWT (2) = ILOWT (1)
7180 0 : ILOWT (1) = IWRK2
7181 : End If
7182 : End If
7183 0 : JLOW = 0
7184 0 : Do ICRS = JHIG + 1, NORD
7185 0 : JLOW = JLOW + 1
7186 0 : IHIGT (ICRS) = ILOWT (JLOW)
7187 : End Do
7188 0 : JHIG = NORD
7189 : Exit
7190 : ! ---
7191 : Case (4 :)
7192 : !
7193 : !
7194 0 : XPIV0 = XPIV
7195 0 : IFIN = JLOW
7196 : !
7197 : ! One chooses a pivot from the 2 first values and the last one.
7198 : ! This should ensure sufficient renewal between iterations to
7199 : ! avoid worst case behavior effects.
7200 : !
7201 0 : IWRK1 = ILOWT (1)
7202 0 : IWRK2 = ILOWT (2)
7203 0 : IWRK3 = ILOWT (IFIN)
7204 0 : If (XDONT(IWRK2) > XDONT(IWRK1)) Then
7205 0 : ILOWT (1) = IWRK2
7206 0 : ILOWT (2) = IWRK1
7207 0 : IWRK2 = IWRK1
7208 : End If
7209 0 : If (XDONT(IWRK2) < XDONT(IWRK3)) Then
7210 0 : ILOWT (IFIN) = IWRK2
7211 0 : ILOWT (2) = IWRK3
7212 0 : IWRK2 = IWRK3
7213 0 : If (XDONT(IWRK2) > XDONT(IHIGT(1))) Then
7214 0 : ILOWT (2) = ILOWT (1)
7215 0 : ILOWT (1) = IWRK2
7216 : End If
7217 : End If
7218 : !
7219 0 : JDEB = JHIG
7220 0 : NWRK = NORD - JHIG
7221 0 : IWRK1 = ILOWT (1)
7222 0 : JHIG = JHIG + 1
7223 0 : IHIGT (JHIG) = IWRK1
7224 0 : XPIV = XDONT (IWRK1) + REAL(NWRK, dp) / REAL(NORD + NWRK, dp) * &
7225 0 : (XDONT(ILOWT(IFIN)) - XDONT(IWRK1))
7226 : !
7227 : ! One takes values >= pivot to IHIGT
7228 : ! Again, 2 parts, one where we take care of the remaining
7229 : ! low values because we might still need them, and the
7230 : ! other when we know that we will have more than enough
7231 : ! high values in the end.
7232 : ! ---
7233 0 : JLOW = 0
7234 0 : Do ICRS = 2, IFIN
7235 0 : If (XDONT(ILOWT(ICRS)) >= XPIV) Then
7236 0 : JHIG = JHIG + 1
7237 0 : IHIGT (JHIG) = ILOWT (ICRS)
7238 0 : If (JHIG >= NORD) Exit
7239 : Else
7240 0 : JLOW = JLOW + 1
7241 0 : ILOWT (JLOW) = ILOWT (ICRS)
7242 : End If
7243 : End Do
7244 : !
7245 0 : Do ICRS = ICRS + 1, IFIN
7246 0 : If (XDONT(ILOWT(ICRS)) >= XPIV) Then
7247 0 : JHIG = JHIG + 1
7248 0 : IHIGT (JHIG) = ILOWT (ICRS)
7249 : End If
7250 : End Do
7251 : End Select
7252 : ! ---
7253 : !
7254 : Case (1)
7255 : !
7256 : ! Only 1 value is missing in high part
7257 : !
7258 0 : XMAX = XDONT (ILOWT(1))
7259 0 : ILOW = 1
7260 0 : Do ICRS = 2, JLOW
7261 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
7262 0 : XMAX = XDONT (ILOWT(ICRS))
7263 0 : ILOW = ICRS
7264 : End If
7265 : End Do
7266 : !
7267 0 : JHIG = JHIG + 1
7268 0 : IHIGT (JHIG) = ILOWT (ILOW)
7269 0 : Exit
7270 : !
7271 : !
7272 : Case (0)
7273 : !
7274 : ! Low part is exactly what we want
7275 : !
7276 0 : Exit
7277 : ! ---
7278 : !
7279 : Case (-5 : -1)
7280 : !
7281 : ! Only few values too many in high part
7282 : !
7283 0 : IRNGT (1) = IHIGT (1)
7284 0 : Do ICRS = 2, NORD
7285 0 : IWRK = IHIGT (ICRS)
7286 0 : XWRK = XDONT (IWRK)
7287 0 : Do IDCR = ICRS - 1, 1, - 1
7288 0 : If (XWRK > XDONT(IRNGT(IDCR))) Then
7289 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
7290 : Else
7291 : Exit
7292 : End If
7293 : End Do
7294 0 : IRNGT (IDCR + 1) = IWRK
7295 : End Do
7296 : !
7297 0 : XWRK1 = XDONT (IRNGT(NORD))
7298 0 : Do ICRS = NORD + 1, JHIG
7299 0 : If (XDONT(IHIGT (ICRS)) > XWRK1) Then
7300 0 : XWRK = XDONT (IHIGT (ICRS))
7301 0 : Do IDCR = NORD - 1, 1, - 1
7302 0 : If (XWRK <= XDONT(IRNGT(IDCR))) Exit
7303 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
7304 : End Do
7305 0 : IRNGT (IDCR + 1) = IHIGT (ICRS)
7306 0 : XWRK1 = XDONT (IRNGT(NORD))
7307 : End If
7308 : End Do
7309 : !
7310 0 : Return
7311 : !
7312 : !
7313 : Case (: -6)
7314 : !
7315 : ! last case: too many values in high part
7316 : ! ---
7317 0 : IDEB = JDEB + 1
7318 0 : IMIL = (JHIG + IDEB) / 2
7319 0 : IFIN = JHIG
7320 : ! ---
7321 : ! One chooses a pivot from 1st, last, and middle values
7322 : !
7323 0 : If (XDONT(IHIGT(IMIL)) > XDONT(IHIGT(IDEB))) Then
7324 0 : IWRK = IHIGT (IDEB)
7325 0 : IHIGT (IDEB) = IHIGT (IMIL)
7326 0 : IHIGT (IMIL) = IWRK
7327 : End If
7328 0 : If (XDONT(IHIGT(IMIL)) < XDONT(IHIGT(IFIN))) Then
7329 0 : IWRK = IHIGT (IFIN)
7330 0 : IHIGT (IFIN) = IHIGT (IMIL)
7331 0 : IHIGT (IMIL) = IWRK
7332 0 : If (XDONT(IHIGT(IMIL)) > XDONT(IHIGT(IDEB))) Then
7333 0 : IWRK = IHIGT (IDEB)
7334 0 : IHIGT (IDEB) = IHIGT (IMIL)
7335 0 : IHIGT (IMIL) = IWRK
7336 : End If
7337 : End If
7338 0 : If (IFIN <= 3) Exit
7339 : ! ---
7340 0 : XPIV = XDONT (IHIGT(1)) + REAL(NORD, sp) / REAL(JHIG + NORD, sp) * &
7341 0 : (XDONT(IHIGT(IFIN)) - XDONT(IHIGT(1)))
7342 0 : If (JDEB > 0) Then
7343 0 : If (XPIV <= XPIV0) &
7344 : XPIV = XPIV0 + REAL(2 * NORD - JDEB, dp) / REAL(JHIG + NORD, dp) * &
7345 0 : (XDONT(IHIGT(IFIN)) - XPIV0)
7346 : Else
7347 : IDEB = 1
7348 : End If
7349 : !
7350 : ! One takes values < XPIV to ILOWT
7351 : ! However, we do not process the first values if we have been
7352 : ! through the case when we did not have enough high values
7353 : ! ---
7354 0 : JLOW = 0
7355 0 : JHIG = JDEB
7356 : ! ---
7357 0 : If (XDONT(IHIGT(IFIN)) < XPIV) Then
7358 : ICRS = JDEB
7359 : Do
7360 0 : ICRS = ICRS + 1
7361 0 : If (XDONT(IHIGT(ICRS)) < XPIV) Then
7362 0 : JLOW = JLOW + 1
7363 0 : ILOWT (JLOW) = IHIGT (ICRS)
7364 0 : If (ICRS >= IFIN) Exit
7365 : Else
7366 0 : JHIG = JHIG + 1
7367 0 : IHIGT (JHIG) = IHIGT (ICRS)
7368 0 : If (JHIG >= NORD) Exit
7369 : End If
7370 : End Do
7371 : ! ---
7372 0 : If (ICRS < IFIN) Then
7373 : Do
7374 0 : ICRS = ICRS + 1
7375 0 : If (XDONT(IHIGT(ICRS)) >= XPIV) Then
7376 0 : JHIG = JHIG + 1
7377 0 : IHIGT (JHIG) = IHIGT (ICRS)
7378 : Else
7379 0 : If (ICRS >= IFIN) Exit
7380 : End If
7381 : End Do
7382 : End If
7383 : Else
7384 0 : Do ICRS = IDEB, IFIN
7385 0 : If (XDONT(IHIGT(ICRS)) < XPIV) Then
7386 0 : JLOW = JLOW + 1
7387 0 : ILOWT (JLOW) = IHIGT (ICRS)
7388 : Else
7389 0 : JHIG = JHIG + 1
7390 0 : IHIGT (JHIG) = IHIGT (ICRS)
7391 0 : If (JHIG >= NORD) Exit
7392 : End If
7393 : End Do
7394 : !
7395 0 : Do ICRS = ICRS + 1, IFIN
7396 0 : If (XDONT(IHIGT(ICRS)) >= XPIV) Then
7397 0 : JHIG = JHIG + 1
7398 0 : IHIGT (JHIG) = IHIGT (ICRS)
7399 : End If
7400 : End Do
7401 : End If
7402 : !
7403 : End Select
7404 : !
7405 : End Do
7406 : ! ---
7407 : ! Now, we only need to complete ranking of the 1:NORD set
7408 : ! Assuming NORD is small, we use a simple insertion sort
7409 : !
7410 0 : IRNGT (1) = IHIGT (1)
7411 0 : Do ICRS = 2, NORD
7412 0 : IWRK = IHIGT (ICRS)
7413 0 : XWRK = XDONT (IWRK)
7414 0 : Do IDCR = ICRS - 1, 1, - 1
7415 0 : If (XWRK > XDONT(IRNGT(IDCR))) Then
7416 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
7417 : Else
7418 : Exit
7419 : End If
7420 : End Do
7421 0 : IRNGT (IDCR + 1) = IWRK
7422 : End Do
7423 : Return
7424 : !
7425 : !
7426 0 : End Subroutine D_rapknr
7427 :
7428 0 : Subroutine R_rapknr (XDONT, IRNGT, NORD)
7429 : ! Ranks partially XDONT by IRNGT, up to order NORD, in decreasing order.
7430 : ! rapknr = (rnkpar backwards)
7431 : ! __________________________________________________________
7432 : ! This routine uses a pivoting strategy such as the one of
7433 : ! finding the median based on the quicksort algorithm, but
7434 : ! we skew the pivot choice to try to bring it to NORD as
7435 : ! fast as possible. It uses 2 temporary arrays, where it
7436 : ! stores the indices of the values larger than the pivot
7437 : ! (IHIGT), and the indices of values smaller than the pivot
7438 : ! that we might still need later on (ILOWT). It iterates
7439 : ! until it can bring the number of values in IHIGT to
7440 : ! exactly NORD, and then uses an insertion sort to rank
7441 : ! this set, since it is supposedly small.
7442 : ! Michel Olagnon - Feb. 2011
7443 : ! __________________________________________________________
7444 : ! __________________________________________________________
7445 : ! _________________________________________________________
7446 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
7447 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
7448 : Integer(kind = i4), Intent (In) :: NORD
7449 : ! __________________________________________________________
7450 0 : Real(kind = sp) :: XPIV, XPIV0, XWRK, XWRK1, XMIN, XMAX
7451 : !
7452 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
7453 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
7454 : Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
7455 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
7456 : !
7457 0 : NDON = SIZE (XDONT)
7458 : !
7459 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
7460 : !
7461 0 : If (NDON < 2) Then
7462 0 : If (NORD >= 1) IRNGT (1) = 1
7463 0 : Return
7464 : End If
7465 : !
7466 : ! One chooses a pivot, best estimate possible to put fractile near
7467 : ! mid-point of the set of high values.
7468 : !
7469 0 : If (XDONT(2) < XDONT(1)) Then
7470 0 : ILOWT (1) = 2
7471 0 : IHIGT (1) = 1
7472 : Else
7473 0 : ILOWT (1) = 1
7474 0 : IHIGT (1) = 2
7475 : End If
7476 : !
7477 0 : If (NDON < 3) Then
7478 0 : If (NORD >= 1) IRNGT (1) = IHIGT (1)
7479 0 : If (NORD >= 2) IRNGT (2) = ILOWT (1)
7480 0 : Return
7481 : End If
7482 : ! ---
7483 0 : If (XDONT(3) > XDONT(ILOWT(1))) Then
7484 0 : ILOWT (2) = ILOWT (1)
7485 0 : If (XDONT(3) > XDONT(IHIGT(1))) Then
7486 0 : ILOWT (1) = IHIGT (1)
7487 0 : IHIGT (1) = 3
7488 : Else
7489 0 : ILOWT (1) = 3
7490 : End If
7491 : Else
7492 0 : ILOWT (2) = 3
7493 : End If
7494 : ! ---
7495 0 : If (NDON < 4) Then
7496 0 : If (NORD >= 1) IRNGT (1) = IHIGT (1)
7497 0 : If (NORD >= 2) IRNGT (2) = ILOWT (1)
7498 0 : If (NORD >= 3) IRNGT (3) = ILOWT (2)
7499 0 : Return
7500 : End If
7501 : !
7502 0 : If (XDONT(NDON) > XDONT(ILOWT(1))) Then
7503 0 : ILOWT (3) = ILOWT (2)
7504 0 : ILOWT (2) = ILOWT (1)
7505 0 : If (XDONT(NDON) > XDONT(IHIGT(1))) Then
7506 0 : ILOWT (1) = IHIGT (1)
7507 0 : IHIGT (1) = NDON
7508 : Else
7509 0 : ILOWT (1) = NDON
7510 : End If
7511 : Else
7512 0 : if (XDONT (NDON) > XDONT (ILOWT(2))) Then
7513 0 : ILOWT (3) = ILOWT (2)
7514 0 : ILOWT (2) = NDON
7515 : else
7516 0 : ILOWT (3) = NDON
7517 : end if
7518 : End If
7519 : !
7520 0 : If (NDON < 5) Then
7521 0 : If (NORD >= 1) IRNGT (1) = IHIGT (1)
7522 0 : If (NORD >= 2) IRNGT (2) = ILOWT (1)
7523 0 : If (NORD >= 3) IRNGT (3) = ILOWT (2)
7524 0 : If (NORD >= 4) IRNGT (4) = ILOWT (3)
7525 0 : Return
7526 : End If
7527 : ! ---
7528 0 : JDEB = 0
7529 0 : IDEB = JDEB + 1
7530 0 : JHIG = IDEB
7531 0 : JLOW = 3
7532 0 : XPIV = XDONT (IHIGT(IDEB)) + REAL(2 * NORD, sp) / REAL(NDON + NORD, sp) * &
7533 0 : (XDONT(ILOWT(3)) - XDONT(IHIGT(IDEB)))
7534 0 : If (XPIV >= XDONT(ILOWT(1))) Then
7535 : XPIV = XDONT (IHIGT(IDEB)) + REAL(2 * NORD, sp) / REAL(NDON + NORD, sp) * &
7536 0 : (XDONT(ILOWT(2)) - XDONT(IHIGT(IDEB)))
7537 0 : If (XPIV >= XDONT(ILOWT(1))) &
7538 : XPIV = XDONT (IHIGT(IDEB)) + REAL(2 * NORD, sp) / REAL(NDON + NORD, sp) * &
7539 0 : (XDONT(ILOWT(1)) - XDONT(IHIGT(IDEB)))
7540 : End If
7541 0 : XPIV0 = XPIV
7542 : ! ---
7543 : ! One puts values < pivot in the end and those >= pivot
7544 : ! at the beginning. This is split in 2 cases, so that
7545 : ! we can skip the loop test a number of times.
7546 : ! As we are also filling in the work arrays at the same time
7547 : ! we stop filling in the ILOWT array as soon as we have more
7548 : ! than enough values in IHIGT.
7549 : !
7550 : !
7551 0 : If (XDONT(NDON) < XPIV) Then
7552 : ICRS = 3
7553 : Do
7554 0 : ICRS = ICRS + 1
7555 0 : If (XDONT(ICRS) < XPIV) Then
7556 0 : If (ICRS >= NDON) Exit
7557 0 : JLOW = JLOW + 1
7558 0 : ILOWT (JLOW) = ICRS
7559 : Else
7560 0 : JHIG = JHIG + 1
7561 0 : IHIGT (JHIG) = ICRS
7562 0 : If (JHIG >= NORD) Exit
7563 : End If
7564 : End Do
7565 : !
7566 : ! One restricts further processing because it is no use
7567 : ! to store more low values
7568 : !
7569 0 : If (ICRS < NDON - 1) Then
7570 : Do
7571 0 : ICRS = ICRS + 1
7572 0 : If (XDONT(ICRS) >= XPIV) Then
7573 0 : JHIG = JHIG + 1
7574 0 : IHIGT (JHIG) = ICRS
7575 0 : Else If (ICRS >= NDON) Then
7576 : Exit
7577 : End If
7578 : End Do
7579 : End If
7580 : !
7581 : ! ---
7582 : Else
7583 : !
7584 : ! Same as above, but this is not as easy to optimize, so the
7585 : ! DO-loop is kept
7586 : !
7587 0 : Do ICRS = 4, NDON - 1
7588 0 : If (XDONT(ICRS) < XPIV) Then
7589 0 : JLOW = JLOW + 1
7590 0 : ILOWT (JLOW) = ICRS
7591 : Else
7592 0 : JHIG = JHIG + 1
7593 0 : IHIGT (JHIG) = ICRS
7594 0 : If (JHIG >= NORD) Exit
7595 : End If
7596 : End Do
7597 : !
7598 0 : If (ICRS < NDON - 1) Then
7599 : Do
7600 0 : ICRS = ICRS + 1
7601 0 : If (XDONT(ICRS) >= XPIV) Then
7602 0 : If (ICRS >= NDON) Exit
7603 0 : JHIG = JHIG + 1
7604 0 : IHIGT (JHIG) = ICRS
7605 : End If
7606 : End Do
7607 : End If
7608 : End If
7609 : ! ---
7610 : JLM2 = 0
7611 : JLM1 = 0
7612 : JHM2 = 0
7613 : JHM1 = 0
7614 : Do
7615 0 : if (JHIG == NORD) Exit
7616 0 : If (JHM2 == JHIG .And. JLM2 == JLOW) Then
7617 : !
7618 : ! We are oscillating. Perturbate by bringing JHIG closer by one
7619 : ! to NORD
7620 : !
7621 0 : If (NORD > JHIG) Then
7622 0 : XMAX = XDONT (ILOWT(1))
7623 0 : ILOW = 1
7624 0 : Do ICRS = 2, JLOW
7625 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
7626 0 : XMAX = XDONT (ILOWT(ICRS))
7627 0 : ILOW = ICRS
7628 : End If
7629 : End Do
7630 : !
7631 0 : JHIG = JHIG + 1
7632 0 : IHIGT (JHIG) = ILOWT (ILOW)
7633 0 : ILOWT (ILOW) = ILOWT (JLOW)
7634 0 : JLOW = JLOW - 1
7635 : Else
7636 0 : IHIG = IHIGT (JHIG)
7637 0 : XMIN = XDONT (IHIG)
7638 0 : Do ICRS = 1, JHIG
7639 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
7640 0 : IWRK = IHIGT (ICRS)
7641 0 : XMIN = XDONT (IWRK)
7642 0 : IHIGT (ICRS) = IHIG
7643 0 : IHIG = IWRK
7644 : End If
7645 : End Do
7646 0 : JHIG = JHIG - 1
7647 : End If
7648 : End If
7649 0 : JLM2 = JLM1
7650 0 : JLM1 = JLOW
7651 0 : JHM2 = JHM1
7652 0 : JHM1 = JHIG
7653 : ! ---
7654 : ! We try to bring the number of values in the high values set
7655 : ! closer to NORD.
7656 : !
7657 0 : Select Case (NORD - JHIG)
7658 : Case (2 :)
7659 : !
7660 : ! Not enough values in low part, at least 2 are missing
7661 : !
7662 : Select Case (JLOW)
7663 : !!!!! CASE DEFAULT
7664 : !!!!! write (*,*) "Assertion failed"
7665 : !!!!! STOP
7666 : !
7667 : ! We make a special case when we have so few values in
7668 : ! the low values set that it is bad performance to choose a pivot
7669 : ! and apply the general algorithm.
7670 : !
7671 : Case (2)
7672 0 : If (XDONT(ILOWT(1)) >= XDONT(ILOWT(2))) Then
7673 0 : JHIG = JHIG + 1
7674 0 : IHIGT (JHIG) = ILOWT (1)
7675 0 : JHIG = JHIG + 1
7676 0 : IHIGT (JHIG) = ILOWT (2)
7677 : Else
7678 0 : JHIG = JHIG + 1
7679 0 : IHIGT (JHIG) = ILOWT (2)
7680 0 : JHIG = JHIG + 1
7681 0 : IHIGT (JHIG) = ILOWT (1)
7682 : End If
7683 : Exit
7684 : ! ---
7685 : Case (3)
7686 : !
7687 : !
7688 0 : IWRK1 = ILOWT (1)
7689 0 : IWRK2 = ILOWT (2)
7690 0 : IWRK3 = ILOWT (3)
7691 0 : If (XDONT(IWRK2) > XDONT(IWRK1)) Then
7692 0 : ILOWT (1) = IWRK2
7693 0 : ILOWT (2) = IWRK1
7694 0 : IWRK2 = IWRK1
7695 : End If
7696 0 : If (XDONT(IWRK2) < XDONT(IWRK3)) Then
7697 0 : ILOWT (3) = IWRK2
7698 0 : ILOWT (2) = IWRK3
7699 0 : IWRK2 = IWRK3
7700 0 : If (XDONT(IWRK2) > XDONT(ILOWT(1))) Then
7701 0 : ILOWT (2) = ILOWT (1)
7702 0 : ILOWT (1) = IWRK2
7703 : End If
7704 : End If
7705 0 : JLOW = 0
7706 0 : Do ICRS = JHIG + 1, NORD
7707 0 : JLOW = JLOW + 1
7708 0 : IHIGT (ICRS) = ILOWT (JLOW)
7709 : End Do
7710 0 : JHIG = NORD
7711 : Exit
7712 : ! ---
7713 : Case (4 :)
7714 : !
7715 : !
7716 0 : XPIV0 = XPIV
7717 0 : IFIN = JLOW
7718 : !
7719 : ! One chooses a pivot from the 2 first values and the last one.
7720 : ! This should ensure sufficient renewal between iterations to
7721 : ! avoid worst case behavior effects.
7722 : !
7723 0 : IWRK1 = ILOWT (1)
7724 0 : IWRK2 = ILOWT (2)
7725 0 : IWRK3 = ILOWT (IFIN)
7726 0 : If (XDONT(IWRK2) > XDONT(IWRK1)) Then
7727 0 : ILOWT (1) = IWRK2
7728 0 : ILOWT (2) = IWRK1
7729 0 : IWRK2 = IWRK1
7730 : End If
7731 0 : If (XDONT(IWRK2) < XDONT(IWRK3)) Then
7732 0 : ILOWT (IFIN) = IWRK2
7733 0 : ILOWT (2) = IWRK3
7734 0 : IWRK2 = IWRK3
7735 0 : If (XDONT(IWRK2) > XDONT(IHIGT(1))) Then
7736 0 : ILOWT (2) = ILOWT (1)
7737 0 : ILOWT (1) = IWRK2
7738 : End If
7739 : End If
7740 : !
7741 0 : JDEB = JHIG
7742 0 : NWRK = NORD - JHIG
7743 0 : IWRK1 = ILOWT (1)
7744 0 : JHIG = JHIG + 1
7745 0 : IHIGT (JHIG) = IWRK1
7746 0 : XPIV = XDONT (IWRK1) + REAL(NWRK, sp) / REAL(NORD + NWRK, sp) * &
7747 0 : (XDONT(ILOWT(IFIN)) - XDONT(IWRK1))
7748 : !
7749 : ! One takes values >= pivot to IHIGT
7750 : ! Again, 2 parts, one where we take care of the remaining
7751 : ! low values because we might still need them, and the
7752 : ! other when we know that we will have more than enough
7753 : ! high values in the end.
7754 : ! ---
7755 0 : JLOW = 0
7756 0 : Do ICRS = 2, IFIN
7757 0 : If (XDONT(ILOWT(ICRS)) >= XPIV) Then
7758 0 : JHIG = JHIG + 1
7759 0 : IHIGT (JHIG) = ILOWT (ICRS)
7760 0 : If (JHIG >= NORD) Exit
7761 : Else
7762 0 : JLOW = JLOW + 1
7763 0 : ILOWT (JLOW) = ILOWT (ICRS)
7764 : End If
7765 : End Do
7766 : !
7767 0 : Do ICRS = ICRS + 1, IFIN
7768 0 : If (XDONT(ILOWT(ICRS)) >= XPIV) Then
7769 0 : JHIG = JHIG + 1
7770 0 : IHIGT (JHIG) = ILOWT (ICRS)
7771 : End If
7772 : End Do
7773 : End Select
7774 : ! ---
7775 : !
7776 : Case (1)
7777 : !
7778 : ! Only 1 value is missing in high part
7779 : !
7780 0 : XMAX = XDONT (ILOWT(1))
7781 0 : ILOW = 1
7782 0 : Do ICRS = 2, JLOW
7783 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
7784 0 : XMAX = XDONT (ILOWT(ICRS))
7785 0 : ILOW = ICRS
7786 : End If
7787 : End Do
7788 : !
7789 0 : JHIG = JHIG + 1
7790 0 : IHIGT (JHIG) = ILOWT (ILOW)
7791 0 : Exit
7792 : !
7793 : !
7794 : Case (0)
7795 : !
7796 : ! Low part is exactly what we want
7797 : !
7798 0 : Exit
7799 : ! ---
7800 : !
7801 : Case (-5 : -1)
7802 : !
7803 : ! Only few values too many in high part
7804 : !
7805 0 : IRNGT (1) = IHIGT (1)
7806 0 : Do ICRS = 2, NORD
7807 0 : IWRK = IHIGT (ICRS)
7808 0 : XWRK = XDONT (IWRK)
7809 0 : Do IDCR = ICRS - 1, 1, - 1
7810 0 : If (XWRK > XDONT(IRNGT(IDCR))) Then
7811 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
7812 : Else
7813 : Exit
7814 : End If
7815 : End Do
7816 0 : IRNGT (IDCR + 1) = IWRK
7817 : End Do
7818 : !
7819 0 : XWRK1 = XDONT (IRNGT(NORD))
7820 0 : Do ICRS = NORD + 1, JHIG
7821 0 : If (XDONT(IHIGT (ICRS)) > XWRK1) Then
7822 0 : XWRK = XDONT (IHIGT (ICRS))
7823 0 : Do IDCR = NORD - 1, 1, - 1
7824 0 : If (XWRK <= XDONT(IRNGT(IDCR))) Exit
7825 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
7826 : End Do
7827 0 : IRNGT (IDCR + 1) = IHIGT (ICRS)
7828 0 : XWRK1 = XDONT (IRNGT(NORD))
7829 : End If
7830 : End Do
7831 : !
7832 0 : Return
7833 : !
7834 : !
7835 : Case (: -6)
7836 : !
7837 : ! last case: too many values in high part
7838 : ! ---
7839 0 : IDEB = JDEB + 1
7840 0 : IMIL = (JHIG + IDEB) / 2
7841 0 : IFIN = JHIG
7842 : ! ---
7843 : ! One chooses a pivot from 1st, last, and middle values
7844 : !
7845 0 : If (XDONT(IHIGT(IMIL)) > XDONT(IHIGT(IDEB))) Then
7846 0 : IWRK = IHIGT (IDEB)
7847 0 : IHIGT (IDEB) = IHIGT (IMIL)
7848 0 : IHIGT (IMIL) = IWRK
7849 : End If
7850 0 : If (XDONT(IHIGT(IMIL)) < XDONT(IHIGT(IFIN))) Then
7851 0 : IWRK = IHIGT (IFIN)
7852 0 : IHIGT (IFIN) = IHIGT (IMIL)
7853 0 : IHIGT (IMIL) = IWRK
7854 0 : If (XDONT(IHIGT(IMIL)) > XDONT(IHIGT(IDEB))) Then
7855 0 : IWRK = IHIGT (IDEB)
7856 0 : IHIGT (IDEB) = IHIGT (IMIL)
7857 0 : IHIGT (IMIL) = IWRK
7858 : End If
7859 : End If
7860 0 : If (IFIN <= 3) Exit
7861 : ! ---
7862 0 : XPIV = XDONT (IHIGT(1)) + REAL(NORD, sp) / REAL(JHIG + NORD, sp) * &
7863 0 : (XDONT(IHIGT(IFIN)) - XDONT(IHIGT(1)))
7864 0 : If (JDEB > 0) Then
7865 0 : If (XPIV <= XPIV0) &
7866 : XPIV = XPIV0 + REAL(2 * NORD - JDEB, sp) / REAL(JHIG + NORD, sp) * &
7867 0 : (XDONT(IHIGT(IFIN)) - XPIV0)
7868 : Else
7869 : IDEB = 1
7870 : End If
7871 : !
7872 : ! One takes values < XPIV to ILOWT
7873 : ! However, we do not process the first values if we have been
7874 : ! through the case when we did not have enough high values
7875 : ! ---
7876 0 : JLOW = 0
7877 0 : JHIG = JDEB
7878 : ! ---
7879 0 : If (XDONT(IHIGT(IFIN)) < XPIV) Then
7880 : ICRS = JDEB
7881 : Do
7882 0 : ICRS = ICRS + 1
7883 0 : If (XDONT(IHIGT(ICRS)) < XPIV) Then
7884 0 : JLOW = JLOW + 1
7885 0 : ILOWT (JLOW) = IHIGT (ICRS)
7886 0 : If (ICRS >= IFIN) Exit
7887 : Else
7888 0 : JHIG = JHIG + 1
7889 0 : IHIGT (JHIG) = IHIGT (ICRS)
7890 0 : If (JHIG >= NORD) Exit
7891 : End If
7892 : End Do
7893 : ! ---
7894 0 : If (ICRS < IFIN) Then
7895 : Do
7896 0 : ICRS = ICRS + 1
7897 0 : If (XDONT(IHIGT(ICRS)) >= XPIV) Then
7898 0 : JHIG = JHIG + 1
7899 0 : IHIGT (JHIG) = IHIGT (ICRS)
7900 : Else
7901 0 : If (ICRS >= IFIN) Exit
7902 : End If
7903 : End Do
7904 : End If
7905 : Else
7906 0 : Do ICRS = IDEB, IFIN
7907 0 : If (XDONT(IHIGT(ICRS)) < XPIV) Then
7908 0 : JLOW = JLOW + 1
7909 0 : ILOWT (JLOW) = IHIGT (ICRS)
7910 : Else
7911 0 : JHIG = JHIG + 1
7912 0 : IHIGT (JHIG) = IHIGT (ICRS)
7913 0 : If (JHIG >= NORD) Exit
7914 : End If
7915 : End Do
7916 : !
7917 0 : Do ICRS = ICRS + 1, IFIN
7918 0 : If (XDONT(IHIGT(ICRS)) >= XPIV) Then
7919 0 : JHIG = JHIG + 1
7920 0 : IHIGT (JHIG) = IHIGT (ICRS)
7921 : End If
7922 : End Do
7923 : End If
7924 : !
7925 : End Select
7926 : !
7927 : End Do
7928 : ! ---
7929 : ! Now, we only need to complete ranking of the 1:NORD set
7930 : ! Assuming NORD is small, we use a simple insertion sort
7931 : !
7932 0 : IRNGT (1) = IHIGT (1)
7933 0 : Do ICRS = 2, NORD
7934 0 : IWRK = IHIGT (ICRS)
7935 0 : XWRK = XDONT (IWRK)
7936 0 : Do IDCR = ICRS - 1, 1, - 1
7937 0 : If (XWRK > XDONT(IRNGT(IDCR))) Then
7938 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
7939 : Else
7940 : Exit
7941 : End If
7942 : End Do
7943 0 : IRNGT (IDCR + 1) = IWRK
7944 : End Do
7945 : Return
7946 : !
7947 : !
7948 0 : End Subroutine R_rapknr
7949 :
7950 0 : Subroutine I_rapknr (XDONT, IRNGT, NORD)
7951 : ! Ranks partially XDONT by IRNGT, up to order NORD, in decreasing order.
7952 : ! rapknr = (rnkpar backwards)
7953 : ! __________________________________________________________
7954 : ! This routine uses a pivoting strategy such as the one of
7955 : ! finding the median based on the quicksort algorithm, but
7956 : ! we skew the pivot choice to try to bring it to NORD as
7957 : ! fast as possible. It uses 2 temporary arrays, where it
7958 : ! stores the indices of the values larger than the pivot
7959 : ! (IHIGT), and the indices of values smaller than the pivot
7960 : ! that we might still need later on (ILOWT). It iterates
7961 : ! until it can bring the number of values in IHIGT to
7962 : ! exactly NORD, and then uses an insertion sort to rank
7963 : ! this set, since it is supposedly small.
7964 : ! Michel Olagnon - Feb. 2011
7965 : ! __________________________________________________________
7966 : ! __________________________________________________________
7967 : ! __________________________________________________________
7968 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
7969 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
7970 : Integer(kind = i4), Intent (In) :: NORD
7971 : ! __________________________________________________________
7972 : Integer(kind = i4) :: XPIV, XPIV0, XWRK, XWRK1, XMIN, XMAX
7973 : !
7974 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
7975 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
7976 : Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
7977 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
7978 : !
7979 0 : NDON = SIZE (XDONT)
7980 : !
7981 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
7982 : !
7983 0 : If (NDON < 2) Then
7984 0 : If (NORD >= 1) IRNGT (1) = 1
7985 0 : Return
7986 : End If
7987 : !
7988 : ! One chooses a pivot, best estimate possible to put fractile near
7989 : ! mid-point of the set of high values.
7990 : !
7991 0 : If (XDONT(2) < XDONT(1)) Then
7992 0 : ILOWT (1) = 2
7993 0 : IHIGT (1) = 1
7994 : Else
7995 0 : ILOWT (1) = 1
7996 0 : IHIGT (1) = 2
7997 : End If
7998 : !
7999 0 : If (NDON < 3) Then
8000 0 : If (NORD >= 1) IRNGT (1) = IHIGT (1)
8001 0 : If (NORD >= 2) IRNGT (2) = ILOWT (1)
8002 0 : Return
8003 : End If
8004 : ! ---
8005 0 : If (XDONT(3) > XDONT(ILOWT(1))) Then
8006 0 : ILOWT (2) = ILOWT (1)
8007 0 : If (XDONT(3) > XDONT(IHIGT(1))) Then
8008 0 : ILOWT (1) = IHIGT (1)
8009 0 : IHIGT (1) = 3
8010 : Else
8011 0 : ILOWT (1) = 3
8012 : End If
8013 : Else
8014 0 : ILOWT (2) = 3
8015 : End If
8016 : ! ---
8017 0 : If (NDON < 4) Then
8018 0 : If (NORD >= 1) IRNGT (1) = IHIGT (1)
8019 0 : If (NORD >= 2) IRNGT (2) = ILOWT (1)
8020 0 : If (NORD >= 3) IRNGT (3) = ILOWT (2)
8021 0 : Return
8022 : End If
8023 : !
8024 0 : If (XDONT(NDON) > XDONT(ILOWT(1))) Then
8025 0 : ILOWT (3) = ILOWT (2)
8026 0 : ILOWT (2) = ILOWT (1)
8027 0 : If (XDONT(NDON) > XDONT(IHIGT(1))) Then
8028 0 : ILOWT (1) = IHIGT (1)
8029 0 : IHIGT (1) = NDON
8030 : Else
8031 0 : ILOWT (1) = NDON
8032 : End If
8033 : Else
8034 0 : if (XDONT (NDON) > XDONT (ILOWT(2))) Then
8035 0 : ILOWT (3) = ILOWT (2)
8036 0 : ILOWT (2) = NDON
8037 : else
8038 0 : ILOWT (3) = NDON
8039 : end if
8040 : End If
8041 : !
8042 0 : If (NDON < 5) Then
8043 0 : If (NORD >= 1) IRNGT (1) = IHIGT (1)
8044 0 : If (NORD >= 2) IRNGT (2) = ILOWT (1)
8045 0 : If (NORD >= 3) IRNGT (3) = ILOWT (2)
8046 0 : If (NORD >= 4) IRNGT (4) = ILOWT (3)
8047 0 : Return
8048 : End If
8049 : ! ---
8050 0 : JDEB = 0
8051 0 : IDEB = JDEB + 1
8052 0 : JHIG = IDEB
8053 0 : JLOW = 3
8054 0 : XPIV = XDONT (IHIGT(IDEB)) + INT(REAL(2 * NORD, sp) / REAL(NDON + NORD, sp), i4) * &
8055 0 : (XDONT(ILOWT(3)) - XDONT(IHIGT(IDEB)))
8056 0 : If (XPIV >= XDONT(ILOWT(1))) Then
8057 : XPIV = XDONT (IHIGT(IDEB)) + INT(REAL(2 * NORD, sp) / REAL(NDON + NORD, sp), i4) * &
8058 0 : (XDONT(ILOWT(2)) - XDONT(IHIGT(IDEB)))
8059 0 : If (XPIV >= XDONT(ILOWT(1))) &
8060 : XPIV = XDONT (IHIGT(IDEB)) + INT(REAL(2 * NORD, sp) / REAL(NDON + NORD, sp), i4) * &
8061 0 : (XDONT(ILOWT(1)) - XDONT(IHIGT(IDEB)))
8062 : End If
8063 0 : XPIV0 = XPIV
8064 : ! ---
8065 : ! One puts values < pivot in the end and those >= pivot
8066 : ! at the beginning. This is split in 2 cases, so that
8067 : ! we can skip the loop test a number of times.
8068 : ! As we are also filling in the work arrays at the same time
8069 : ! we stop filling in the ILOWT array as soon as we have more
8070 : ! than enough values in IHIGT.
8071 : !
8072 : !
8073 0 : If (XDONT(NDON) < XPIV) Then
8074 : ICRS = 3
8075 : Do
8076 0 : ICRS = ICRS + 1
8077 0 : If (XDONT(ICRS) < XPIV) Then
8078 0 : If (ICRS >= NDON) Exit
8079 0 : JLOW = JLOW + 1
8080 0 : ILOWT (JLOW) = ICRS
8081 : Else
8082 0 : JHIG = JHIG + 1
8083 0 : IHIGT (JHIG) = ICRS
8084 0 : If (JHIG >= NORD) Exit
8085 : End If
8086 : End Do
8087 : !
8088 : ! One restricts further processing because it is no use
8089 : ! to store more low values
8090 : !
8091 0 : If (ICRS < NDON - 1) Then
8092 : Do
8093 0 : ICRS = ICRS + 1
8094 0 : If (XDONT(ICRS) >= XPIV) Then
8095 0 : JHIG = JHIG + 1
8096 0 : IHIGT (JHIG) = ICRS
8097 0 : Else If (ICRS >= NDON) Then
8098 : Exit
8099 : End If
8100 : End Do
8101 : End If
8102 : !
8103 : ! ---
8104 : Else
8105 : !
8106 : ! Same as above, but this is not as easy to optimize, so the
8107 : ! DO-loop is kept
8108 : !
8109 0 : Do ICRS = 4, NDON - 1
8110 0 : If (XDONT(ICRS) < XPIV) Then
8111 0 : JLOW = JLOW + 1
8112 0 : ILOWT (JLOW) = ICRS
8113 : Else
8114 0 : JHIG = JHIG + 1
8115 0 : IHIGT (JHIG) = ICRS
8116 0 : If (JHIG >= NORD) Exit
8117 : End If
8118 : End Do
8119 : !
8120 0 : If (ICRS < NDON - 1) Then
8121 : Do
8122 0 : ICRS = ICRS + 1
8123 0 : If (XDONT(ICRS) >= XPIV) Then
8124 0 : If (ICRS >= NDON) Exit
8125 0 : JHIG = JHIG + 1
8126 0 : IHIGT (JHIG) = ICRS
8127 : End If
8128 : End Do
8129 : End If
8130 : End If
8131 : ! ---
8132 : JLM2 = 0
8133 : JLM1 = 0
8134 : JHM2 = 0
8135 : JHM1 = 0
8136 : Do
8137 0 : if (JHIG == NORD) Exit
8138 0 : If (JHM2 == JHIG .And. JLM2 == JLOW) Then
8139 : !
8140 : ! We are oscillating. Perturbate by bringing JHIG closer by one
8141 : ! to NORD
8142 : !
8143 0 : If (NORD > JHIG) Then
8144 0 : XMAX = XDONT (ILOWT(1))
8145 0 : ILOW = 1
8146 0 : Do ICRS = 2, JLOW
8147 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
8148 0 : XMAX = XDONT (ILOWT(ICRS))
8149 0 : ILOW = ICRS
8150 : End If
8151 : End Do
8152 : !
8153 0 : JHIG = JHIG + 1
8154 0 : IHIGT (JHIG) = ILOWT (ILOW)
8155 0 : ILOWT (ILOW) = ILOWT (JLOW)
8156 0 : JLOW = JLOW - 1
8157 : Else
8158 0 : IHIG = IHIGT (JHIG)
8159 0 : XMIN = XDONT (IHIG)
8160 0 : Do ICRS = 1, JHIG
8161 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
8162 0 : IWRK = IHIGT (ICRS)
8163 0 : XMIN = XDONT (IWRK)
8164 0 : IHIGT (ICRS) = IHIG
8165 0 : IHIG = IWRK
8166 : End If
8167 : End Do
8168 0 : JHIG = JHIG - 1
8169 : End If
8170 : End If
8171 0 : JLM2 = JLM1
8172 0 : JLM1 = JLOW
8173 0 : JHM2 = JHM1
8174 0 : JHM1 = JHIG
8175 : ! ---
8176 : ! We try to bring the number of values in the high values set
8177 : ! closer to NORD.
8178 : !
8179 0 : Select Case (NORD - JHIG)
8180 : Case (2 :)
8181 : !
8182 : ! Not enough values in low part, at least 2 are missing
8183 : !
8184 : Select Case (JLOW)
8185 : !!!!! CASE DEFAULT
8186 : !!!!! write (*,*) "Assertion failed"
8187 : !!!!! STOP
8188 : !
8189 : ! We make a special case when we have so few values in
8190 : ! the low values set that it is bad performance to choose a pivot
8191 : ! and apply the general algorithm.
8192 : !
8193 : Case (2)
8194 0 : If (XDONT(ILOWT(1)) >= XDONT(ILOWT(2))) Then
8195 0 : JHIG = JHIG + 1
8196 0 : IHIGT (JHIG) = ILOWT (1)
8197 0 : JHIG = JHIG + 1
8198 0 : IHIGT (JHIG) = ILOWT (2)
8199 : Else
8200 0 : JHIG = JHIG + 1
8201 0 : IHIGT (JHIG) = ILOWT (2)
8202 0 : JHIG = JHIG + 1
8203 0 : IHIGT (JHIG) = ILOWT (1)
8204 : End If
8205 : Exit
8206 : ! ---
8207 : Case (3)
8208 : !
8209 : !
8210 0 : IWRK1 = ILOWT (1)
8211 0 : IWRK2 = ILOWT (2)
8212 0 : IWRK3 = ILOWT (3)
8213 0 : If (XDONT(IWRK2) > XDONT(IWRK1)) Then
8214 0 : ILOWT (1) = IWRK2
8215 0 : ILOWT (2) = IWRK1
8216 0 : IWRK2 = IWRK1
8217 : End If
8218 0 : If (XDONT(IWRK2) < XDONT(IWRK3)) Then
8219 0 : ILOWT (3) = IWRK2
8220 0 : ILOWT (2) = IWRK3
8221 0 : IWRK2 = IWRK3
8222 0 : If (XDONT(IWRK2) > XDONT(ILOWT(1))) Then
8223 0 : ILOWT (2) = ILOWT (1)
8224 0 : ILOWT (1) = IWRK2
8225 : End If
8226 : End If
8227 0 : JLOW = 0
8228 0 : Do ICRS = JHIG + 1, NORD
8229 0 : JLOW = JLOW + 1
8230 0 : IHIGT (ICRS) = ILOWT (JLOW)
8231 : End Do
8232 0 : JHIG = NORD
8233 : Exit
8234 : ! ---
8235 : Case (4 :)
8236 : !
8237 : !
8238 0 : XPIV0 = XPIV
8239 0 : IFIN = JLOW
8240 : !
8241 : ! One chooses a pivot from the 2 first values and the last one.
8242 : ! This should ensure sufficient renewal between iterations to
8243 : ! avoid worst case behavior effects.
8244 : !
8245 0 : IWRK1 = ILOWT (1)
8246 0 : IWRK2 = ILOWT (2)
8247 0 : IWRK3 = ILOWT (IFIN)
8248 0 : If (XDONT(IWRK2) > XDONT(IWRK1)) Then
8249 0 : ILOWT (1) = IWRK2
8250 0 : ILOWT (2) = IWRK1
8251 0 : IWRK2 = IWRK1
8252 : End If
8253 0 : If (XDONT(IWRK2) < XDONT(IWRK3)) Then
8254 0 : ILOWT (IFIN) = IWRK2
8255 0 : ILOWT (2) = IWRK3
8256 0 : IWRK2 = IWRK3
8257 0 : If (XDONT(IWRK2) > XDONT(IHIGT(1))) Then
8258 0 : ILOWT (2) = ILOWT (1)
8259 0 : ILOWT (1) = IWRK2
8260 : End If
8261 : End If
8262 : !
8263 0 : JDEB = JHIG
8264 0 : NWRK = NORD - JHIG
8265 0 : IWRK1 = ILOWT (1)
8266 0 : JHIG = JHIG + 1
8267 0 : IHIGT (JHIG) = IWRK1
8268 0 : XPIV = XDONT (IWRK1) + INT(REAL(NWRK, sp) / REAL(NORD + NWRK, sp), i4) * &
8269 0 : (XDONT(ILOWT(IFIN)) - XDONT(IWRK1))
8270 : !
8271 : ! One takes values >= pivot to IHIGT
8272 : ! Again, 2 parts, one where we take care of the remaining
8273 : ! low values because we might still need them, and the
8274 : ! other when we know that we will have more than enough
8275 : ! high values in the end.
8276 : ! ---
8277 0 : JLOW = 0
8278 0 : Do ICRS = 2, IFIN
8279 0 : If (XDONT(ILOWT(ICRS)) >= XPIV) Then
8280 0 : JHIG = JHIG + 1
8281 0 : IHIGT (JHIG) = ILOWT (ICRS)
8282 0 : If (JHIG >= NORD) Exit
8283 : Else
8284 0 : JLOW = JLOW + 1
8285 0 : ILOWT (JLOW) = ILOWT (ICRS)
8286 : End If
8287 : End Do
8288 : !
8289 0 : Do ICRS = ICRS + 1, IFIN
8290 0 : If (XDONT(ILOWT(ICRS)) >= XPIV) Then
8291 0 : JHIG = JHIG + 1
8292 0 : IHIGT (JHIG) = ILOWT (ICRS)
8293 : End If
8294 : End Do
8295 : End Select
8296 : ! ---
8297 : !
8298 : Case (1)
8299 : !
8300 : ! Only 1 value is missing in high part
8301 : !
8302 0 : XMAX = XDONT (ILOWT(1))
8303 0 : ILOW = 1
8304 0 : Do ICRS = 2, JLOW
8305 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
8306 0 : XMAX = XDONT (ILOWT(ICRS))
8307 0 : ILOW = ICRS
8308 : End If
8309 : End Do
8310 : !
8311 0 : JHIG = JHIG + 1
8312 0 : IHIGT (JHIG) = ILOWT (ILOW)
8313 0 : Exit
8314 : !
8315 : !
8316 : Case (0)
8317 : !
8318 : ! Low part is exactly what we want
8319 : !
8320 0 : Exit
8321 : ! ---
8322 : !
8323 : Case (-5 : -1)
8324 : !
8325 : ! Only few values too many in high part
8326 : !
8327 0 : IRNGT (1) = IHIGT (1)
8328 0 : Do ICRS = 2, NORD
8329 0 : IWRK = IHIGT (ICRS)
8330 0 : XWRK = XDONT (IWRK)
8331 0 : Do IDCR = ICRS - 1, 1, - 1
8332 0 : If (XWRK > XDONT(IRNGT(IDCR))) Then
8333 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
8334 : Else
8335 : Exit
8336 : End If
8337 : End Do
8338 0 : IRNGT (IDCR + 1) = IWRK
8339 : End Do
8340 : !
8341 0 : XWRK1 = XDONT (IRNGT(NORD))
8342 0 : Do ICRS = NORD + 1, JHIG
8343 0 : If (XDONT(IHIGT (ICRS)) > XWRK1) Then
8344 0 : XWRK = XDONT (IHIGT (ICRS))
8345 0 : Do IDCR = NORD - 1, 1, - 1
8346 0 : If (XWRK <= XDONT(IRNGT(IDCR))) Exit
8347 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
8348 : End Do
8349 0 : IRNGT (IDCR + 1) = IHIGT (ICRS)
8350 0 : XWRK1 = XDONT (IRNGT(NORD))
8351 : End If
8352 : End Do
8353 : !
8354 0 : Return
8355 : !
8356 : !
8357 : Case (: -6)
8358 : !
8359 : ! last case: too many values in high part
8360 : ! ---
8361 0 : IDEB = JDEB + 1
8362 0 : IMIL = (JHIG + IDEB) / 2
8363 0 : IFIN = JHIG
8364 : ! ---
8365 : ! One chooses a pivot from 1st, last, and middle values
8366 : !
8367 0 : If (XDONT(IHIGT(IMIL)) > XDONT(IHIGT(IDEB))) Then
8368 0 : IWRK = IHIGT (IDEB)
8369 0 : IHIGT (IDEB) = IHIGT (IMIL)
8370 0 : IHIGT (IMIL) = IWRK
8371 : End If
8372 0 : If (XDONT(IHIGT(IMIL)) < XDONT(IHIGT(IFIN))) Then
8373 0 : IWRK = IHIGT (IFIN)
8374 0 : IHIGT (IFIN) = IHIGT (IMIL)
8375 0 : IHIGT (IMIL) = IWRK
8376 0 : If (XDONT(IHIGT(IMIL)) > XDONT(IHIGT(IDEB))) Then
8377 0 : IWRK = IHIGT (IDEB)
8378 0 : IHIGT (IDEB) = IHIGT (IMIL)
8379 0 : IHIGT (IMIL) = IWRK
8380 : End If
8381 : End If
8382 0 : If (IFIN <= 3) Exit
8383 : ! ---
8384 0 : XPIV = XDONT (IHIGT(1)) + INT(REAL(NORD, sp) / REAL(JHIG + NORD, sp), i4) * &
8385 0 : (XDONT(IHIGT(IFIN)) - XDONT(IHIGT(1)))
8386 0 : If (JDEB > 0) Then
8387 0 : If (XPIV <= XPIV0) &
8388 : XPIV = XPIV0 + INT(REAL(2 * NORD - JDEB, sp) / REAL(JHIG + NORD, sp), i4) * &
8389 0 : (XDONT(IHIGT(IFIN)) - XPIV0)
8390 : Else
8391 : IDEB = 1
8392 : End If
8393 : !
8394 : ! One takes values < XPIV to ILOWT
8395 : ! However, we do not process the first values if we have been
8396 : ! through the case when we did not have enough high values
8397 : ! ---
8398 0 : JLOW = 0
8399 0 : JHIG = JDEB
8400 : ! ---
8401 0 : If (XDONT(IHIGT(IFIN)) < XPIV) Then
8402 : ICRS = JDEB
8403 : Do
8404 0 : ICRS = ICRS + 1
8405 0 : If (XDONT(IHIGT(ICRS)) < XPIV) Then
8406 0 : JLOW = JLOW + 1
8407 0 : ILOWT (JLOW) = IHIGT (ICRS)
8408 0 : If (ICRS >= IFIN) Exit
8409 : Else
8410 0 : JHIG = JHIG + 1
8411 0 : IHIGT (JHIG) = IHIGT (ICRS)
8412 0 : If (JHIG >= NORD) Exit
8413 : End If
8414 : End Do
8415 : ! ---
8416 0 : If (ICRS < IFIN) Then
8417 : Do
8418 0 : ICRS = ICRS + 1
8419 0 : If (XDONT(IHIGT(ICRS)) >= XPIV) Then
8420 0 : JHIG = JHIG + 1
8421 0 : IHIGT (JHIG) = IHIGT (ICRS)
8422 : Else
8423 0 : If (ICRS >= IFIN) Exit
8424 : End If
8425 : End Do
8426 : End If
8427 : Else
8428 0 : Do ICRS = IDEB, IFIN
8429 0 : If (XDONT(IHIGT(ICRS)) < XPIV) Then
8430 0 : JLOW = JLOW + 1
8431 0 : ILOWT (JLOW) = IHIGT (ICRS)
8432 : Else
8433 0 : JHIG = JHIG + 1
8434 0 : IHIGT (JHIG) = IHIGT (ICRS)
8435 0 : If (JHIG >= NORD) Exit
8436 : End If
8437 : End Do
8438 : !
8439 0 : Do ICRS = ICRS + 1, IFIN
8440 0 : If (XDONT(IHIGT(ICRS)) >= XPIV) Then
8441 0 : JHIG = JHIG + 1
8442 0 : IHIGT (JHIG) = IHIGT (ICRS)
8443 : End If
8444 : End Do
8445 : End If
8446 : !
8447 : End Select
8448 : !
8449 : End Do
8450 : ! ---
8451 : ! Now, we only need to complete ranking of the 1:NORD set
8452 : ! Assuming NORD is small, we use a simple insertion sort
8453 : !
8454 0 : IRNGT (1) = IHIGT (1)
8455 0 : Do ICRS = 2, NORD
8456 0 : IWRK = IHIGT (ICRS)
8457 0 : XWRK = XDONT (IWRK)
8458 0 : Do IDCR = ICRS - 1, 1, - 1
8459 0 : If (XWRK > XDONT(IRNGT(IDCR))) Then
8460 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
8461 : Else
8462 : Exit
8463 : End If
8464 : End Do
8465 0 : IRNGT (IDCR + 1) = IWRK
8466 : End Do
8467 : Return
8468 : !
8469 : !
8470 0 : End Subroutine I_rapknr
8471 :
8472 0 : Subroutine D_refpar (XDONT, IRNGT, NORD)
8473 : ! Ranks partially XDONT by IRNGT, up to order NORD
8474 : ! __________________________________________________________
8475 : ! This routine uses a pivoting strategy such as the one of
8476 : ! finding the median based on the quicksort algorithm. It uses
8477 : ! a temporary array, where it stores the partially ranked indices
8478 : ! of the values. It iterates until it can bring the number of
8479 : ! values lower than the pivot to exactly NORD, and then uses an
8480 : ! insertion sort to rank this set, since it is supposedly small.
8481 : ! Michel Olagnon - Feb. 2000
8482 : ! __________________________________________________________
8483 : ! __________________________________________________________
8484 : real(kind = dp), Dimension (:), Intent (In) :: XDONT
8485 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
8486 : Integer(kind = i4), Intent (In) :: NORD
8487 : ! __________________________________________________________
8488 0 : real(kind = dp) :: XPIV, XWRK
8489 : ! __________________________________________________________
8490 : !
8491 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: IWRKT
8492 : Integer(kind = i4) :: NDON, ICRS, IDEB, IDCR, IFIN, IMIL, IWRK
8493 : !
8494 0 : NDON = SIZE (XDONT)
8495 : !
8496 0 : Do ICRS = 1, NDON
8497 0 : IWRKT (ICRS) = ICRS
8498 : End Do
8499 : IDEB = 1
8500 : IFIN = NDON
8501 : Do
8502 0 : If (IDEB >= IFIN) Exit
8503 0 : IMIL = (IDEB + IFIN) / 2
8504 : !
8505 : ! One chooses a pivot, median of 1st, last, and middle values
8506 : !
8507 0 : If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
8508 0 : IWRK = IWRKT (IDEB)
8509 0 : IWRKT (IDEB) = IWRKT (IMIL)
8510 0 : IWRKT (IMIL) = IWRK
8511 : End If
8512 0 : If (XDONT(IWRKT(IMIL)) > XDONT(IWRKT(IFIN))) Then
8513 0 : IWRK = IWRKT (IFIN)
8514 0 : IWRKT (IFIN) = IWRKT (IMIL)
8515 0 : IWRKT (IMIL) = IWRK
8516 0 : If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
8517 0 : IWRK = IWRKT (IDEB)
8518 0 : IWRKT (IDEB) = IWRKT (IMIL)
8519 0 : IWRKT (IMIL) = IWRK
8520 : End If
8521 : End If
8522 0 : If ((IFIN - IDEB) < 3) Exit
8523 0 : XPIV = XDONT (IWRKT(IMIL))
8524 : !
8525 : ! One exchanges values to put those > pivot in the end and
8526 : ! those <= pivot at the beginning
8527 : !
8528 0 : ICRS = IDEB
8529 0 : IDCR = IFIN
8530 0 : ECH2 : Do
8531 : Do
8532 0 : ICRS = ICRS + 1
8533 0 : If (ICRS >= IDCR) Then
8534 : !
8535 : ! the first > pivot is IWRKT(IDCR)
8536 : ! the last <= pivot is IWRKT(ICRS-1)
8537 : ! Note: If one arrives here on the first iteration, then
8538 : ! the pivot is the maximum of the set, the last value is equal
8539 : ! to it, and one can reduce by one the size of the set to process,
8540 : ! as if XDONT (IWRKT(IFIN)) > XPIV
8541 : !
8542 : Exit ECH2
8543 : !
8544 : End If
8545 0 : If (XDONT(IWRKT(ICRS)) > XPIV) Exit
8546 : End Do
8547 : Do
8548 0 : If (XDONT(IWRKT(IDCR)) <= XPIV) Exit
8549 0 : IDCR = IDCR - 1
8550 0 : If (ICRS >= IDCR) Then
8551 : !
8552 : ! The last value < pivot is always IWRKT(ICRS-1)
8553 : !
8554 : Exit ECH2
8555 : End If
8556 : End Do
8557 : !
8558 0 : IWRK = IWRKT (IDCR)
8559 0 : IWRKT (IDCR) = IWRKT (ICRS)
8560 0 : IWRKT (ICRS) = IWRK
8561 : End Do ECH2
8562 : !
8563 : ! One restricts further processing to find the fractile value
8564 : !
8565 0 : If (ICRS <= NORD) IDEB = ICRS
8566 0 : If (ICRS > NORD) IFIN = ICRS - 1
8567 : End Do
8568 : !
8569 : ! Now, we only need to complete ranking of the 1:NORD set
8570 : ! Assuming NORD is small, we use a simple insertion sort
8571 : !
8572 0 : Do ICRS = 2, NORD
8573 0 : IWRK = IWRKT (ICRS)
8574 0 : XWRK = XDONT (IWRK)
8575 0 : Do IDCR = ICRS - 1, 1, - 1
8576 0 : If (XWRK <= XDONT(IWRKT(IDCR))) Then
8577 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
8578 : Else
8579 : Exit
8580 : End If
8581 : End Do
8582 0 : IWRKT (IDCR + 1) = IWRK
8583 : End Do
8584 0 : IRNGT (1 : NORD) = IWRKT (1 : NORD)
8585 0 : Return
8586 : !
8587 0 : End Subroutine D_refpar
8588 :
8589 0 : Subroutine R_refpar (XDONT, IRNGT, NORD)
8590 : ! Ranks partially XDONT by IRNGT, up to order NORD
8591 : ! __________________________________________________________
8592 : ! This routine uses a pivoting strategy such as the one of
8593 : ! finding the median based on the quicksort algorithm. It uses
8594 : ! a temporary array, where it stores the partially ranked indices
8595 : ! of the values. It iterates until it can bring the number of
8596 : ! values lower than the pivot to exactly NORD, and then uses an
8597 : ! insertion sort to rank this set, since it is supposedly small.
8598 : ! Michel Olagnon - Feb. 2000
8599 : ! __________________________________________________________
8600 : ! _________________________________________________________
8601 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
8602 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
8603 : Integer(kind = i4), Intent (In) :: NORD
8604 : ! __________________________________________________________
8605 0 : Real(kind = sp) :: XPIV, XWRK
8606 : ! __________________________________________________________
8607 : !
8608 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: IWRKT
8609 : Integer(kind = i4) :: NDON, ICRS, IDEB, IDCR, IFIN, IMIL, IWRK
8610 : !
8611 0 : NDON = SIZE (XDONT)
8612 : !
8613 0 : Do ICRS = 1, NDON
8614 0 : IWRKT (ICRS) = ICRS
8615 : End Do
8616 : IDEB = 1
8617 : IFIN = NDON
8618 : Do
8619 0 : If (IDEB >= IFIN) Exit
8620 0 : IMIL = (IDEB + IFIN) / 2
8621 : !
8622 : ! One chooses a pivot, median of 1st, last, and middle values
8623 : !
8624 0 : If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
8625 0 : IWRK = IWRKT (IDEB)
8626 0 : IWRKT (IDEB) = IWRKT (IMIL)
8627 0 : IWRKT (IMIL) = IWRK
8628 : End If
8629 0 : If (XDONT(IWRKT(IMIL)) > XDONT(IWRKT(IFIN))) Then
8630 0 : IWRK = IWRKT (IFIN)
8631 0 : IWRKT (IFIN) = IWRKT (IMIL)
8632 0 : IWRKT (IMIL) = IWRK
8633 0 : If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
8634 0 : IWRK = IWRKT (IDEB)
8635 0 : IWRKT (IDEB) = IWRKT (IMIL)
8636 0 : IWRKT (IMIL) = IWRK
8637 : End If
8638 : End If
8639 0 : If ((IFIN - IDEB) < 3) Exit
8640 0 : XPIV = XDONT (IWRKT(IMIL))
8641 : !
8642 : ! One exchanges values to put those > pivot in the end and
8643 : ! those <= pivot at the beginning
8644 : !
8645 0 : ICRS = IDEB
8646 0 : IDCR = IFIN
8647 0 : ECH2 : Do
8648 : Do
8649 0 : ICRS = ICRS + 1
8650 0 : If (ICRS >= IDCR) Then
8651 : !
8652 : ! the first > pivot is IWRKT(IDCR)
8653 : ! the last <= pivot is IWRKT(ICRS-1)
8654 : ! Note: If one arrives here on the first iteration, then
8655 : ! the pivot is the maximum of the set, the last value is equal
8656 : ! to it, and one can reduce by one the size of the set to process,
8657 : ! as if XDONT (IWRKT(IFIN)) > XPIV
8658 : !
8659 : Exit ECH2
8660 : !
8661 : End If
8662 0 : If (XDONT(IWRKT(ICRS)) > XPIV) Exit
8663 : End Do
8664 : Do
8665 0 : If (XDONT(IWRKT(IDCR)) <= XPIV) Exit
8666 0 : IDCR = IDCR - 1
8667 0 : If (ICRS >= IDCR) Then
8668 : !
8669 : ! The last value < pivot is always IWRKT(ICRS-1)
8670 : !
8671 : Exit ECH2
8672 : End If
8673 : End Do
8674 : !
8675 0 : IWRK = IWRKT (IDCR)
8676 0 : IWRKT (IDCR) = IWRKT (ICRS)
8677 0 : IWRKT (ICRS) = IWRK
8678 : End Do ECH2
8679 : !
8680 : ! One restricts further processing to find the fractile value
8681 : !
8682 0 : If (ICRS <= NORD) IDEB = ICRS
8683 0 : If (ICRS > NORD) IFIN = ICRS - 1
8684 : End Do
8685 : !
8686 : ! Now, we only need to complete ranking of the 1:NORD set
8687 : ! Assuming NORD is small, we use a simple insertion sort
8688 : !
8689 0 : Do ICRS = 2, NORD
8690 0 : IWRK = IWRKT (ICRS)
8691 0 : XWRK = XDONT (IWRK)
8692 0 : Do IDCR = ICRS - 1, 1, - 1
8693 0 : If (XWRK <= XDONT(IWRKT(IDCR))) Then
8694 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
8695 : Else
8696 : Exit
8697 : End If
8698 : End Do
8699 0 : IWRKT (IDCR + 1) = IWRK
8700 : End Do
8701 0 : IRNGT (1 : NORD) = IWRKT (1 : NORD)
8702 0 : Return
8703 : !
8704 0 : End Subroutine R_refpar
8705 :
8706 0 : Subroutine I_refpar (XDONT, IRNGT, NORD)
8707 : ! Ranks partially XDONT by IRNGT, up to order NORD
8708 : ! __________________________________________________________
8709 : ! This routine uses a pivoting strategy such as the one of
8710 : ! finding the median based on the quicksort algorithm. It uses
8711 : ! a temporary array, where it stores the partially ranked indices
8712 : ! of the values. It iterates until it can bring the number of
8713 : ! values lower than the pivot to exactly NORD, and then uses an
8714 : ! insertion sort to rank this set, since it is supposedly small.
8715 : ! Michel Olagnon - Feb. 2000
8716 : ! __________________________________________________________
8717 : ! __________________________________________________________
8718 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
8719 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
8720 : Integer(kind = i4), Intent (In) :: NORD
8721 : ! __________________________________________________________
8722 : Integer(kind = i4) :: XPIV, XWRK
8723 : !
8724 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: IWRKT
8725 : Integer(kind = i4) :: NDON, ICRS, IDEB, IDCR, IFIN, IMIL, IWRK
8726 : !
8727 0 : NDON = SIZE (XDONT)
8728 : !
8729 0 : Do ICRS = 1, NDON
8730 0 : IWRKT (ICRS) = ICRS
8731 : End Do
8732 : IDEB = 1
8733 : IFIN = NDON
8734 : Do
8735 0 : If (IDEB >= IFIN) Exit
8736 0 : IMIL = (IDEB + IFIN) / 2
8737 : !
8738 : ! One chooses a pivot, median of 1st, last, and middle values
8739 : !
8740 0 : If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
8741 0 : IWRK = IWRKT (IDEB)
8742 0 : IWRKT (IDEB) = IWRKT (IMIL)
8743 0 : IWRKT (IMIL) = IWRK
8744 : End If
8745 0 : If (XDONT(IWRKT(IMIL)) > XDONT(IWRKT(IFIN))) Then
8746 0 : IWRK = IWRKT (IFIN)
8747 0 : IWRKT (IFIN) = IWRKT (IMIL)
8748 0 : IWRKT (IMIL) = IWRK
8749 0 : If (XDONT(IWRKT(IMIL)) < XDONT(IWRKT(IDEB))) Then
8750 0 : IWRK = IWRKT (IDEB)
8751 0 : IWRKT (IDEB) = IWRKT (IMIL)
8752 0 : IWRKT (IMIL) = IWRK
8753 : End If
8754 : End If
8755 0 : If ((IFIN - IDEB) < 3) Exit
8756 0 : XPIV = XDONT (IWRKT(IMIL))
8757 : !
8758 : ! One exchanges values to put those > pivot in the end and
8759 : ! those <= pivot at the beginning
8760 : !
8761 0 : ICRS = IDEB
8762 0 : IDCR = IFIN
8763 0 : ECH2 : Do
8764 : Do
8765 0 : ICRS = ICRS + 1
8766 0 : If (ICRS >= IDCR) Then
8767 : !
8768 : ! the first > pivot is IWRKT(IDCR)
8769 : ! the last <= pivot is IWRKT(ICRS-1)
8770 : ! Note: If one arrives here on the first iteration, then
8771 : ! the pivot is the maximum of the set, the last value is equal
8772 : ! to it, and one can reduce by one the size of the set to process,
8773 : ! as if XDONT (IWRKT(IFIN)) > XPIV
8774 : !
8775 : Exit ECH2
8776 : !
8777 : End If
8778 0 : If (XDONT(IWRKT(ICRS)) > XPIV) Exit
8779 : End Do
8780 : Do
8781 0 : If (XDONT(IWRKT(IDCR)) <= XPIV) Exit
8782 0 : IDCR = IDCR - 1
8783 0 : If (ICRS >= IDCR) Then
8784 : !
8785 : ! The last value < pivot is always IWRKT(ICRS-1)
8786 : !
8787 : Exit ECH2
8788 : End If
8789 : End Do
8790 : !
8791 0 : IWRK = IWRKT (IDCR)
8792 0 : IWRKT (IDCR) = IWRKT (ICRS)
8793 0 : IWRKT (ICRS) = IWRK
8794 : End Do ECH2
8795 : !
8796 : ! One restricts further processing to find the fractile value
8797 : !
8798 0 : If (ICRS <= NORD) IDEB = ICRS
8799 0 : If (ICRS > NORD) IFIN = ICRS - 1
8800 : End Do
8801 : !
8802 : ! Now, we only need to complete ranking of the 1:NORD set
8803 : ! Assuming NORD is small, we use a simple insertion sort
8804 : !
8805 0 : Do ICRS = 2, NORD
8806 0 : IWRK = IWRKT (ICRS)
8807 0 : XWRK = XDONT (IWRK)
8808 0 : Do IDCR = ICRS - 1, 1, - 1
8809 0 : If (XWRK <= XDONT(IWRKT(IDCR))) Then
8810 0 : IWRKT (IDCR + 1) = IWRKT (IDCR)
8811 : Else
8812 : Exit
8813 : End If
8814 : End Do
8815 0 : IWRKT (IDCR + 1) = IWRK
8816 : End Do
8817 0 : IRNGT (1 : NORD) = IWRKT (1 : NORD)
8818 0 : Return
8819 : !
8820 0 : End Subroutine I_refpar
8821 :
8822 4 : Subroutine D_refsor (XDONT)
8823 : ! Sorts XDONT into ascending order - Quicksort
8824 : ! __________________________________________________________
8825 : ! Quicksort chooses a "pivot" in the set, and explores the
8826 : ! array from both ends, looking for a value > pivot with the
8827 : ! increasing index, for a value <= pivot with the decreasing
8828 : ! index, and swapping them when it has found one of each.
8829 : ! The array is then subdivided in 2 ([3]) subsets:
8830 : ! { values <= pivot} {pivot} {values > pivot}
8831 : ! One then call recursively the program to sort each subset.
8832 : ! When the size of the subarray is small enough, one uses an
8833 : ! insertion sort that is faster for very small sets.
8834 : ! Michel Olagnon - Apr. 2000
8835 : ! __________________________________________________________
8836 : ! __________________________________________________________
8837 : real(kind = dp), Dimension (:), Intent (InOut) :: XDONT
8838 : ! __________________________________________________________
8839 : !
8840 : !
8841 4 : Call D_subsor (XDONT, 1, Size (XDONT))
8842 4 : Call D_inssor (XDONT)
8843 4 : Return
8844 0 : End Subroutine D_refsor
8845 :
8846 28 : Recursive Subroutine D_subsor (XDONT, IDEB1, IFIN1)
8847 : ! Sorts XDONT from IDEB1 to IFIN1
8848 : ! __________________________________________________________
8849 : Real(kind = dp), dimension (:), Intent (InOut) :: XDONT
8850 : Integer(kind = i4), Intent (In) :: IDEB1, IFIN1
8851 : ! __________________________________________________________
8852 : Integer(kind = i4), Parameter :: NINS = 16 ! Max for insertion sort
8853 : Integer(kind = i4) :: ICRS, IDEB, IDCR, IFIN, IMIL
8854 28 : Real(kind = dp) :: XPIV, XWRK
8855 : !
8856 28 : IDEB = IDEB1
8857 28 : IFIN = IFIN1
8858 : !
8859 : ! If we don't have enough values to make it worth while, we leave
8860 : ! them unsorted, and the final insertion sort will take care of them
8861 : !
8862 28 : If ((IFIN - IDEB) > NINS) Then
8863 12 : IMIL = (IDEB + IFIN) / 2
8864 : !
8865 : ! One chooses a pivot, median of 1st, last, and middle values
8866 : !
8867 12 : If (XDONT(IMIL) < XDONT(IDEB)) Then
8868 6 : XWRK = XDONT (IDEB)
8869 6 : XDONT (IDEB) = XDONT (IMIL)
8870 6 : XDONT (IMIL) = XWRK
8871 : End If
8872 12 : If (XDONT(IMIL) > XDONT(IFIN)) Then
8873 5 : XWRK = XDONT (IFIN)
8874 5 : XDONT (IFIN) = XDONT (IMIL)
8875 5 : XDONT (IMIL) = XWRK
8876 5 : If (XDONT(IMIL) < XDONT(IDEB)) Then
8877 1 : XWRK = XDONT (IDEB)
8878 1 : XDONT (IDEB) = XDONT (IMIL)
8879 1 : XDONT (IMIL) = XWRK
8880 : End If
8881 : End If
8882 12 : XPIV = XDONT (IMIL)
8883 : !
8884 : ! One exchanges values to put those > pivot in the end and
8885 : ! those <= pivot at the beginning
8886 : !
8887 12 : ICRS = IDEB
8888 12 : IDCR = IFIN
8889 93 : ECH2 : Do
8890 : Do
8891 224 : ICRS = ICRS + 1
8892 224 : If (ICRS >= IDCR) Then
8893 : !
8894 : ! the first > pivot is IDCR
8895 : ! the last <= pivot is ICRS-1
8896 : ! Note: If one arrives here on the first iteration, then
8897 : ! the pivot is the maximum of the set, the last value is equal
8898 : ! to it, and one can reduce by one the size of the set to process,
8899 : ! as if XDONT (IFIN) > XPIV
8900 : !
8901 : Exit ECH2
8902 : !
8903 : End If
8904 218 : If (XDONT(ICRS) > XPIV) Exit
8905 : End Do
8906 : Do
8907 378 : If (XDONT(IDCR) <= XPIV) Exit
8908 285 : IDCR = IDCR - 1
8909 378 : If (ICRS >= IDCR) Then
8910 : !
8911 : ! The last value < pivot is always ICRS-1
8912 : !
8913 : Exit ECH2
8914 : End If
8915 : End Do
8916 : !
8917 93 : XWRK = XDONT (IDCR)
8918 93 : XDONT (IDCR) = XDONT (ICRS)
8919 99 : XDONT (ICRS) = XWRK
8920 : End Do ECH2
8921 : !
8922 : ! One now sorts each of the two sub-intervals
8923 : !
8924 12 : Call D_subsor (XDONT, IDEB1, ICRS - 1)
8925 12 : Call D_subsor (XDONT, IDCR, IFIN1)
8926 : End If
8927 28 : Return
8928 4 : End Subroutine D_subsor
8929 : !
8930 2 : Subroutine R_refsor (XDONT)
8931 : ! Sorts XDONT into ascending order - Quicksort
8932 : ! __________________________________________________________
8933 : ! Quicksort chooses a "pivot" in the set, and explores the
8934 : ! array from both ends, looking for a value > pivot with the
8935 : ! increasing index, for a value <= pivot with the decreasing
8936 : ! index, and swapping them when it has found one of each.
8937 : ! The array is then subdivided in 2 ([3]) subsets:
8938 : ! { values <= pivot} {pivot} {values > pivot}
8939 : ! One then call recursively the program to sort each subset.
8940 : ! When the size of the subarray is small enough, one uses an
8941 : ! insertion sort that is faster for very small sets.
8942 : ! Michel Olagnon - Apr. 2000
8943 : ! __________________________________________________________
8944 : ! _________________________________________________________
8945 : Real(kind = sp), Dimension (:), Intent (InOut) :: XDONT
8946 : ! __________________________________________________________
8947 : !
8948 : !
8949 2 : Call R_subsor (XDONT, 1, Size (XDONT))
8950 2 : Call R_inssor (XDONT)
8951 2 : Return
8952 2 : End Subroutine R_refsor
8953 :
8954 2 : Recursive Subroutine R_subsor (XDONT, IDEB1, IFIN1)
8955 : ! Sorts XDONT from IDEB1 to IFIN1
8956 : ! __________________________________________________________
8957 : Real(kind = sp), dimension (:), Intent (InOut) :: XDONT
8958 : Integer(kind = i4), Intent (In) :: IDEB1, IFIN1
8959 : ! __________________________________________________________
8960 : Integer(kind = i4), Parameter :: NINS = 16 ! Max for insertion sort
8961 : Integer(kind = i4) :: ICRS, IDEB, IDCR, IFIN, IMIL
8962 2 : Real(kind = sp) :: XPIV, XWRK
8963 : !
8964 2 : IDEB = IDEB1
8965 2 : IFIN = IFIN1
8966 : !
8967 : ! If we don't have enough values to make it worth while, we leave
8968 : ! them unsorted, and the final insertion sort will take care of them
8969 : !
8970 2 : If ((IFIN - IDEB) > NINS) Then
8971 0 : IMIL = (IDEB + IFIN) / 2
8972 : !
8973 : ! One chooses a pivot, median of 1st, last, and middle values
8974 : !
8975 0 : If (XDONT(IMIL) < XDONT(IDEB)) Then
8976 0 : XWRK = XDONT (IDEB)
8977 0 : XDONT (IDEB) = XDONT (IMIL)
8978 0 : XDONT (IMIL) = XWRK
8979 : End If
8980 0 : If (XDONT(IMIL) > XDONT(IFIN)) Then
8981 0 : XWRK = XDONT (IFIN)
8982 0 : XDONT (IFIN) = XDONT (IMIL)
8983 0 : XDONT (IMIL) = XWRK
8984 0 : If (XDONT(IMIL) < XDONT(IDEB)) Then
8985 0 : XWRK = XDONT (IDEB)
8986 0 : XDONT (IDEB) = XDONT (IMIL)
8987 0 : XDONT (IMIL) = XWRK
8988 : End If
8989 : End If
8990 0 : XPIV = XDONT (IMIL)
8991 : !
8992 : ! One exchanges values to put those > pivot in the end and
8993 : ! those <= pivot at the beginning
8994 : !
8995 0 : ICRS = IDEB
8996 0 : IDCR = IFIN
8997 0 : ECH2 : Do
8998 : Do
8999 0 : ICRS = ICRS + 1
9000 0 : If (ICRS >= IDCR) Then
9001 : !
9002 : ! the first > pivot is IDCR
9003 : ! the last <= pivot is ICRS-1
9004 : ! Note: If one arrives here on the first iteration, then
9005 : ! the pivot is the maximum of the set, the last value is equal
9006 : ! to it, and one can reduce by one the size of the set to process,
9007 : ! as if XDONT (IFIN) > XPIV
9008 : !
9009 : Exit ECH2
9010 : !
9011 : End If
9012 0 : If (XDONT(ICRS) > XPIV) Exit
9013 : End Do
9014 : Do
9015 0 : If (XDONT(IDCR) <= XPIV) Exit
9016 0 : IDCR = IDCR - 1
9017 0 : If (ICRS >= IDCR) Then
9018 : !
9019 : ! The last value < pivot is always ICRS-1
9020 : !
9021 : Exit ECH2
9022 : End If
9023 : End Do
9024 : !
9025 0 : XWRK = XDONT (IDCR)
9026 0 : XDONT (IDCR) = XDONT (ICRS)
9027 0 : XDONT (ICRS) = XWRK
9028 : End Do ECH2
9029 : !
9030 : ! One now sorts each of the two sub-intervals
9031 : !
9032 0 : Call R_subsor (XDONT, IDEB1, ICRS - 1)
9033 0 : Call R_subsor (XDONT, IDCR, IFIN1)
9034 : End If
9035 2 : Return
9036 2 : End Subroutine R_subsor
9037 : !
9038 4452 : Subroutine I_refsor (XDONT)
9039 : ! Sorts XDONT into ascending order - Quicksort
9040 : ! __________________________________________________________
9041 : ! Quicksort chooses a "pivot" in the set, and explores the
9042 : ! array from both ends, looking for a value > pivot with the
9043 : ! increasing index, for a value <= pivot with the decreasing
9044 : ! index, and swapping them when it has found one of each.
9045 : ! The array is then subdivided in 2 ([3]) subsets:
9046 : ! { values <= pivot} {pivot} {values > pivot}
9047 : ! One then call recursively the program to sort each subset.
9048 : ! When the size of the subarray is small enough, one uses an
9049 : ! insertion sort that is faster for very small sets.
9050 : ! Michel Olagnon - Apr. 2000
9051 : ! __________________________________________________________
9052 : ! __________________________________________________________
9053 : Integer(kind = i4), Dimension (:), Intent (InOut) :: XDONT
9054 : ! __________________________________________________________
9055 : !
9056 : !
9057 4452 : Call I_subsor (XDONT, 1, Size (XDONT))
9058 4452 : Call I_inssor (XDONT)
9059 4452 : Return
9060 4452 : End Subroutine I_refsor
9061 :
9062 21382 : Recursive Subroutine I_subsor (XDONT, IDEB1, IFIN1)
9063 : ! Sorts XDONT from IDEB1 to IFIN1
9064 : ! __________________________________________________________
9065 : Integer(kind = i4), dimension (:), Intent (InOut) :: XDONT
9066 : Integer(kind = i4), Intent (In) :: IDEB1, IFIN1
9067 : ! __________________________________________________________
9068 : Integer(kind = i4), Parameter :: NINS = 16 ! Max for insertion sort
9069 : Integer(kind = i4) :: ICRS, IDEB, IDCR, IFIN, IMIL
9070 : Integer(kind = i4) :: XPIV, XWRK
9071 : !
9072 21382 : IDEB = IDEB1
9073 21382 : IFIN = IFIN1
9074 : !
9075 : ! If we don't have enough values to make it worth while, we leave
9076 : ! them unsorted, and the final insertion sort will take care of them
9077 : !
9078 21382 : If ((IFIN - IDEB) > NINS) Then
9079 8465 : IMIL = (IDEB + IFIN) / 2
9080 : !
9081 : ! One chooses a pivot, median of 1st, last, and middle values
9082 : !
9083 8465 : If (XDONT(IMIL) < XDONT(IDEB)) Then
9084 4029 : XWRK = XDONT (IDEB)
9085 4029 : XDONT (IDEB) = XDONT (IMIL)
9086 4029 : XDONT (IMIL) = XWRK
9087 : End If
9088 8465 : If (XDONT(IMIL) > XDONT(IFIN)) Then
9089 5259 : XWRK = XDONT (IFIN)
9090 5259 : XDONT (IFIN) = XDONT (IMIL)
9091 5259 : XDONT (IMIL) = XWRK
9092 5259 : If (XDONT(IMIL) < XDONT(IDEB)) Then
9093 2472 : XWRK = XDONT (IDEB)
9094 2472 : XDONT (IDEB) = XDONT (IMIL)
9095 2472 : XDONT (IMIL) = XWRK
9096 : End If
9097 : End If
9098 8465 : XPIV = XDONT (IMIL)
9099 : !
9100 : ! One exchanges values to put those > pivot in the end and
9101 : ! those <= pivot at the beginning
9102 : !
9103 8465 : ICRS = IDEB
9104 8465 : IDCR = IFIN
9105 38761 : ECH2 : Do
9106 : Do
9107 114798 : ICRS = ICRS + 1
9108 114798 : If (ICRS >= IDCR) Then
9109 : !
9110 : ! the first > pivot is IDCR
9111 : ! the last <= pivot is ICRS-1
9112 : ! Note: If one arrives here on the first iteration, then
9113 : ! the pivot is the maximum of the set, the last value is equal
9114 : ! to it, and one can reduce by one the size of the set to process,
9115 : ! as if XDONT (IFIN) > XPIV
9116 : !
9117 : Exit ECH2
9118 : !
9119 : End If
9120 110444 : If (XDONT(ICRS) > XPIV) Exit
9121 : End Do
9122 : Do
9123 139434 : If (XDONT(IDCR) <= XPIV) Exit
9124 100673 : IDCR = IDCR - 1
9125 139434 : If (ICRS >= IDCR) Then
9126 : !
9127 : ! The last value < pivot is always ICRS-1
9128 : !
9129 : Exit ECH2
9130 : End If
9131 : End Do
9132 : !
9133 38761 : XWRK = XDONT (IDCR)
9134 38761 : XDONT (IDCR) = XDONT (ICRS)
9135 42872 : XDONT (ICRS) = XWRK
9136 : End Do ECH2
9137 : !
9138 : ! One now sorts each of the two sub-intervals
9139 : !
9140 8465 : Call I_subsor (XDONT, IDEB1, ICRS - 1)
9141 8465 : Call I_subsor (XDONT, IDCR, IFIN1)
9142 : End If
9143 21382 : Return
9144 4452 : End Subroutine I_subsor
9145 :
9146 0 : Subroutine C_refsor (XDONT)
9147 : ! Sorts XDONT into ascending order - Quicksort
9148 : ! __________________________________________________________
9149 : ! Quicksort chooses a "pivot" in the set, and explores the
9150 : ! array from both ends, looking for a value > pivot with the
9151 : ! increasing index, for a value <= pivot with the decreasing
9152 : ! index, and swapping them when it has found one of each.
9153 : ! The array is then subdivided in 2 ([3]) subsets:
9154 : ! { values <= pivot} {pivot} {values > pivot}
9155 : ! One then call recursively the program to sort each subset.
9156 : ! When the size of the subarray is small enough, one uses an
9157 : ! insertion sort that is faster for very small sets.
9158 : ! Michel Olagnon - Apr. 2000
9159 : ! __________________________________________________________
9160 : ! __________________________________________________________
9161 : character(*), Dimension (:), Intent (InOut) :: XDONT
9162 : ! __________________________________________________________
9163 : !
9164 : !
9165 0 : Call C_subsor (XDONT, 1, Size (XDONT))
9166 0 : Call C_inssor (XDONT)
9167 0 : Return
9168 0 : End Subroutine C_refsor
9169 :
9170 0 : Recursive Subroutine C_subsor (XDONT, IDEB1, IFIN1)
9171 : ! Sorts XDONT from IDEB1 to IFIN1
9172 : ! __________________________________________________________
9173 : character(*), dimension (:), Intent (InOut) :: XDONT
9174 : Integer(kind = i4), Intent (In) :: IDEB1, IFIN1
9175 : ! __________________________________________________________
9176 : Integer(kind = i4), Parameter :: NINS = 16 ! Max for insertion sort
9177 : Integer(kind = i4) :: ICRS, IDEB, IDCR, IFIN, IMIL
9178 0 : character(len(XDONT)) :: XPIV, XWRK
9179 : !
9180 0 : IDEB = IDEB1
9181 0 : IFIN = IFIN1
9182 : !
9183 : ! If we don't have enough values to make it worth while, we leave
9184 : ! them unsorted, and the final insertion sort will take care of them
9185 : !
9186 0 : If ((IFIN - IDEB) > NINS) Then
9187 0 : IMIL = (IDEB + IFIN) / 2
9188 : !
9189 : ! One chooses a pivot, median of 1st, last, and middle values
9190 : !
9191 0 : If (XDONT(IMIL) < XDONT(IDEB)) Then
9192 0 : XWRK = XDONT (IDEB)
9193 0 : XDONT (IDEB) = XDONT (IMIL)
9194 0 : XDONT (IMIL) = XWRK
9195 : End If
9196 0 : If (XDONT(IMIL) > XDONT(IFIN)) Then
9197 0 : XWRK = XDONT (IFIN)
9198 0 : XDONT (IFIN) = XDONT (IMIL)
9199 0 : XDONT (IMIL) = XWRK
9200 0 : If (XDONT(IMIL) < XDONT(IDEB)) Then
9201 0 : XWRK = XDONT (IDEB)
9202 0 : XDONT (IDEB) = XDONT (IMIL)
9203 0 : XDONT (IMIL) = XWRK
9204 : End If
9205 : End If
9206 0 : XPIV = XDONT (IMIL)
9207 : !
9208 : ! One exchanges values to put those > pivot in the end and
9209 : ! those <= pivot at the beginning
9210 : !
9211 0 : ICRS = IDEB
9212 0 : IDCR = IFIN
9213 : ECH2 : Do
9214 : Do
9215 0 : ICRS = ICRS + 1
9216 0 : If (ICRS >= IDCR) Then
9217 : !
9218 : ! the first > pivot is IDCR
9219 : ! the last <= pivot is ICRS-1
9220 : ! Note: If one arrives here on the first iteration, then
9221 : ! the pivot is the maximum of the set, the last value is equal
9222 : ! to it, and one can reduce by one the size of the set to process,
9223 : ! as if XDONT (IFIN) > XPIV
9224 : !
9225 : Exit ECH2
9226 : !
9227 : End If
9228 0 : If (XDONT(ICRS) > XPIV) Exit
9229 : End Do
9230 : Do
9231 0 : If (XDONT(IDCR) <= XPIV) Exit
9232 0 : IDCR = IDCR - 1
9233 0 : If (ICRS >= IDCR) Then
9234 : !
9235 : ! The last value < pivot is always ICRS-1
9236 : !
9237 : Exit ECH2
9238 : End If
9239 : End Do
9240 : !
9241 0 : XWRK = XDONT (IDCR)
9242 0 : XDONT (IDCR) = XDONT (ICRS)
9243 0 : XDONT (ICRS) = XWRK
9244 : End Do ECH2
9245 : !
9246 : ! One now sorts each of the two sub-intervals
9247 : !
9248 0 : Call C_subsor (XDONT, IDEB1, ICRS - 1)
9249 0 : Call C_subsor (XDONT, IDCR, IFIN1)
9250 : End If
9251 0 : Return
9252 0 : End Subroutine C_subsor
9253 : !
9254 0 : Subroutine D_rinpar (XDONT, IRNGT, NORD)
9255 : ! Ranks partially XDONT by IRNGT, up to order NORD = size (IRNGT)
9256 : ! __________________________________________________________
9257 : ! This subroutine uses insertion sort, limiting insertion
9258 : ! to the first NORD values. It does not use any work array
9259 : ! and is faster when NORD is very small (2-5), but worst case
9260 : ! behavior can happen fairly probably (initially inverse sorted)
9261 : ! In many cases, the refined quicksort method is faster.
9262 : ! Michel Olagnon - Feb. 2000
9263 : ! __________________________________________________________
9264 : ! __________________________________________________________
9265 : real(kind = dp), Dimension (:), Intent (In) :: XDONT
9266 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
9267 : Integer(kind = i4), Intent (In) :: NORD
9268 : ! __________________________________________________________
9269 0 : real(kind = dp) :: XWRK, XWRK1
9270 : !
9271 : Integer(kind = i4) :: ICRS, IDCR
9272 : !
9273 0 : IRNGT (1) = 1
9274 0 : Do ICRS = 2, NORD
9275 0 : XWRK = XDONT (ICRS)
9276 0 : Do IDCR = ICRS - 1, 1, - 1
9277 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
9278 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
9279 : End Do
9280 0 : IRNGT (IDCR + 1) = ICRS
9281 : End Do
9282 : !
9283 0 : XWRK1 = XDONT (IRNGT(NORD))
9284 0 : Do ICRS = NORD + 1, SIZE (XDONT)
9285 0 : If (XDONT(ICRS) < XWRK1) Then
9286 0 : XWRK = XDONT (ICRS)
9287 0 : Do IDCR = NORD - 1, 1, - 1
9288 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
9289 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
9290 : End Do
9291 0 : IRNGT (IDCR + 1) = ICRS
9292 0 : XWRK1 = XDONT (IRNGT(NORD))
9293 : End If
9294 : End Do
9295 : !
9296 : !
9297 0 : End Subroutine D_rinpar
9298 :
9299 0 : Subroutine R_rinpar (XDONT, IRNGT, NORD)
9300 : ! Ranks partially XDONT by IRNGT, up to order NORD = size (IRNGT)
9301 : ! __________________________________________________________
9302 : ! This subroutine uses insertion sort, limiting insertion
9303 : ! to the first NORD values. It does not use any work array
9304 : ! and is faster when NORD is very small (2-5), but worst case
9305 : ! behavior can happen fairly probably (initially inverse sorted)
9306 : ! In many cases, the refined quicksort method is faster.
9307 : ! Michel Olagnon - Feb. 2000
9308 : ! __________________________________________________________
9309 : ! _________________________________________________________
9310 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
9311 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
9312 : Integer(kind = i4), Intent (In) :: NORD
9313 : ! __________________________________________________________
9314 0 : Real(kind = sp) :: XWRK, XWRK1
9315 : !
9316 : Integer(kind = i4) :: ICRS, IDCR
9317 : !
9318 0 : IRNGT (1) = 1
9319 0 : Do ICRS = 2, NORD
9320 0 : XWRK = XDONT (ICRS)
9321 0 : Do IDCR = ICRS - 1, 1, - 1
9322 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
9323 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
9324 : End Do
9325 0 : IRNGT (IDCR + 1) = ICRS
9326 : End Do
9327 : !
9328 0 : XWRK1 = XDONT (IRNGT(NORD))
9329 0 : Do ICRS = NORD + 1, SIZE (XDONT)
9330 0 : If (XDONT(ICRS) < XWRK1) Then
9331 0 : XWRK = XDONT (ICRS)
9332 0 : Do IDCR = NORD - 1, 1, - 1
9333 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
9334 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
9335 : End Do
9336 0 : IRNGT (IDCR + 1) = ICRS
9337 0 : XWRK1 = XDONT (IRNGT(NORD))
9338 : End If
9339 : End Do
9340 : !
9341 : !
9342 0 : End Subroutine R_rinpar
9343 :
9344 0 : Subroutine I_rinpar (XDONT, IRNGT, NORD)
9345 : ! Ranks partially XDONT by IRNGT, up to order NORD = size (IRNGT)
9346 : ! __________________________________________________________
9347 : ! This subroutine uses insertion sort, limiting insertion
9348 : ! to the first NORD values. It does not use any work array
9349 : ! and is faster when NORD is very small (2-5), but worst case
9350 : ! behavior can happen fairly probably (initially inverse sorted)
9351 : ! In many cases, the refined quicksort method is faster.
9352 : ! Michel Olagnon - Feb. 2000
9353 : ! __________________________________________________________
9354 : ! __________________________________________________________
9355 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
9356 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
9357 : Integer(kind = i4), Intent (In) :: NORD
9358 : ! __________________________________________________________
9359 : Integer(kind = i4) :: XWRK, XWRK1
9360 : !
9361 : Integer(kind = i4) :: ICRS, IDCR
9362 : !
9363 0 : IRNGT (1) = 1
9364 0 : Do ICRS = 2, NORD
9365 0 : XWRK = XDONT (ICRS)
9366 0 : Do IDCR = ICRS - 1, 1, - 1
9367 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
9368 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
9369 : End Do
9370 0 : IRNGT (IDCR + 1) = ICRS
9371 : End Do
9372 : !
9373 0 : XWRK1 = XDONT (IRNGT(NORD))
9374 0 : Do ICRS = NORD + 1, SIZE (XDONT)
9375 0 : If (XDONT(ICRS) < XWRK1) Then
9376 0 : XWRK = XDONT (ICRS)
9377 0 : Do IDCR = NORD - 1, 1, - 1
9378 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
9379 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
9380 : End Do
9381 0 : IRNGT (IDCR + 1) = ICRS
9382 0 : XWRK1 = XDONT (IRNGT(NORD))
9383 : End If
9384 : End Do
9385 : !
9386 : !
9387 0 : End Subroutine I_rinpar
9388 :
9389 0 : Subroutine D_rnkpar (XDONT, IRNGT, NORD)
9390 : ! Ranks partially XDONT by IRNGT, up to order NORD
9391 : ! __________________________________________________________
9392 : ! This routine uses a pivoting strategy such as the one of
9393 : ! finding the median based on the quicksort algorithm, but
9394 : ! we skew the pivot choice to try to bring it to NORD as
9395 : ! fast as possible. It uses 2 temporary arrays, where it
9396 : ! stores the indices of the values smaller than the pivot
9397 : ! (ILOWT), and the indices of values larger than the pivot
9398 : ! that we might still need later on (IHIGT). It iterates
9399 : ! until it can bring the number of values in ILOWT to
9400 : ! exactly NORD, and then uses an insertion sort to rank
9401 : ! this set, since it is supposedly small.
9402 : ! Michel Olagnon - Feb. 2000
9403 : ! __________________________________________________________
9404 : ! __________________________________________________________
9405 : real(kind = dp), Dimension (:), Intent (In) :: XDONT
9406 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
9407 : Integer(kind = i4), Intent (In) :: NORD
9408 : ! __________________________________________________________
9409 0 : real(kind = dp) :: XPIV, XPIV0, XWRK, XWRK1, XMIN, XMAX
9410 : !
9411 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
9412 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
9413 : Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
9414 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
9415 : !
9416 0 : NDON = SIZE (XDONT)
9417 : !
9418 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
9419 : !
9420 0 : If (NDON < 2) Then
9421 0 : If (NORD >= 1) IRNGT (1) = 1
9422 0 : Return
9423 : End If
9424 : !
9425 : ! One chooses a pivot, best estimate possible to put fractile near
9426 : ! mid-point of the set of low values.
9427 : !
9428 0 : If (XDONT(2) < XDONT(1)) Then
9429 0 : ILOWT (1) = 2
9430 0 : IHIGT (1) = 1
9431 : Else
9432 0 : ILOWT (1) = 1
9433 0 : IHIGT (1) = 2
9434 : End If
9435 : !
9436 0 : If (NDON < 3) Then
9437 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
9438 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
9439 0 : Return
9440 : End If
9441 : !
9442 0 : If (XDONT(3) <= XDONT(IHIGT(1))) Then
9443 0 : IHIGT (2) = IHIGT (1)
9444 0 : If (XDONT(3) < XDONT(ILOWT(1))) Then
9445 0 : IHIGT (1) = ILOWT (1)
9446 0 : ILOWT (1) = 3
9447 : Else
9448 0 : IHIGT (1) = 3
9449 : End If
9450 : Else
9451 0 : IHIGT (2) = 3
9452 : End If
9453 : !
9454 0 : If (NDON < 4) Then
9455 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
9456 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
9457 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
9458 0 : Return
9459 : End If
9460 : !
9461 0 : If (XDONT(NDON) <= XDONT(IHIGT(1))) Then
9462 0 : IHIGT (3) = IHIGT (2)
9463 0 : IHIGT (2) = IHIGT (1)
9464 0 : If (XDONT(NDON) < XDONT(ILOWT(1))) Then
9465 0 : IHIGT (1) = ILOWT (1)
9466 0 : ILOWT (1) = NDON
9467 : Else
9468 0 : IHIGT (1) = NDON
9469 : End If
9470 : Else
9471 0 : if (XDONT (NDON) < XDONT (IHIGT(2))) Then
9472 0 : IHIGT (3) = IHIGT (2)
9473 0 : IHIGT (2) = NDON
9474 : else
9475 0 : IHIGT (3) = NDON
9476 : end if
9477 : End If
9478 : !
9479 0 : If (NDON < 5) Then
9480 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
9481 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
9482 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
9483 0 : If (NORD >= 4) IRNGT (4) = IHIGT (3)
9484 0 : Return
9485 : End If
9486 : !
9487 0 : JDEB = 0
9488 0 : IDEB = JDEB + 1
9489 0 : JLOW = IDEB
9490 0 : JHIG = 3
9491 0 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, dp) / REAL(NDON + NORD, dp) * &
9492 0 : (XDONT(IHIGT(3)) - XDONT(ILOWT(IDEB)))
9493 0 : If (XPIV >= XDONT(IHIGT(1))) Then
9494 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, dp) / REAL(NDON + NORD, dp) * &
9495 0 : (XDONT(IHIGT(2)) - XDONT(ILOWT(IDEB)))
9496 0 : If (XPIV >= XDONT(IHIGT(1))) &
9497 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, dp) / REAL(NDON + NORD, dp) * &
9498 0 : (XDONT(IHIGT(1)) - XDONT(ILOWT(IDEB)))
9499 : End If
9500 0 : XPIV0 = XPIV
9501 : !
9502 : ! One puts values > pivot in the end and those <= pivot
9503 : ! at the beginning. This is split in 2 cases, so that
9504 : ! we can skip the loop test a number of times.
9505 : ! As we are also filling in the work arrays at the same time
9506 : ! we stop filling in the IHIGT array as soon as we have more
9507 : ! than enough values in ILOWT.
9508 : !
9509 : !
9510 0 : If (XDONT(NDON) > XPIV) Then
9511 : ICRS = 3
9512 : Do
9513 0 : ICRS = ICRS + 1
9514 0 : If (XDONT(ICRS) > XPIV) Then
9515 0 : If (ICRS >= NDON) Exit
9516 0 : JHIG = JHIG + 1
9517 0 : IHIGT (JHIG) = ICRS
9518 : Else
9519 0 : JLOW = JLOW + 1
9520 0 : ILOWT (JLOW) = ICRS
9521 0 : If (JLOW >= NORD) Exit
9522 : End If
9523 : End Do
9524 : !
9525 : ! One restricts further processing because it is no use
9526 : ! to store more high values
9527 : !
9528 0 : If (ICRS < NDON - 1) Then
9529 : Do
9530 0 : ICRS = ICRS + 1
9531 0 : If (XDONT(ICRS) <= XPIV) Then
9532 0 : JLOW = JLOW + 1
9533 0 : ILOWT (JLOW) = ICRS
9534 0 : Else If (ICRS >= NDON) Then
9535 : Exit
9536 : End If
9537 : End Do
9538 : End If
9539 : !
9540 : !
9541 : Else
9542 : !
9543 : ! Same as above, but this is not as easy to optimize, so the
9544 : ! DO-loop is kept
9545 : !
9546 0 : Do ICRS = 4, NDON - 1
9547 0 : If (XDONT(ICRS) > XPIV) Then
9548 0 : JHIG = JHIG + 1
9549 0 : IHIGT (JHIG) = ICRS
9550 : Else
9551 0 : JLOW = JLOW + 1
9552 0 : ILOWT (JLOW) = ICRS
9553 0 : If (JLOW >= NORD) Exit
9554 : End If
9555 : End Do
9556 : !
9557 0 : If (ICRS < NDON - 1) Then
9558 : Do
9559 0 : ICRS = ICRS + 1
9560 0 : If (XDONT(ICRS) <= XPIV) Then
9561 0 : If (ICRS >= NDON) Exit
9562 0 : JLOW = JLOW + 1
9563 0 : ILOWT (JLOW) = ICRS
9564 : End If
9565 : End Do
9566 : End If
9567 : End If
9568 : !
9569 : JLM2 = 0
9570 : JLM1 = 0
9571 : JHM2 = 0
9572 : JHM1 = 0
9573 : Do
9574 0 : if (JLOW == NORD) Exit
9575 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
9576 : !
9577 : ! We are oscillating. Perturbate by bringing JLOW closer by one
9578 : ! to NORD
9579 : !
9580 0 : If (NORD > JLOW) Then
9581 0 : XMIN = XDONT (IHIGT(1))
9582 0 : IHIG = 1
9583 0 : Do ICRS = 2, JHIG
9584 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
9585 0 : XMIN = XDONT (IHIGT(ICRS))
9586 0 : IHIG = ICRS
9587 : End If
9588 : End Do
9589 : !
9590 0 : JLOW = JLOW + 1
9591 0 : ILOWT (JLOW) = IHIGT (IHIG)
9592 0 : IHIGT (IHIG) = IHIGT (JHIG)
9593 0 : JHIG = JHIG - 1
9594 : Else
9595 0 : ILOW = ILOWT (JLOW)
9596 0 : XMAX = XDONT (ILOW)
9597 0 : Do ICRS = 1, JLOW
9598 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
9599 0 : IWRK = ILOWT (ICRS)
9600 0 : XMAX = XDONT (IWRK)
9601 0 : ILOWT (ICRS) = ILOW
9602 0 : ILOW = IWRK
9603 : End If
9604 : End Do
9605 0 : JLOW = JLOW - 1
9606 : End If
9607 : End If
9608 0 : JLM2 = JLM1
9609 0 : JLM1 = JLOW
9610 0 : JHM2 = JHM1
9611 0 : JHM1 = JHIG
9612 : !
9613 : ! We try to bring the number of values in the low values set
9614 : ! closer to NORD.
9615 : !
9616 0 : Select Case (NORD - JLOW)
9617 : Case (2 :)
9618 : !
9619 : ! Not enough values in low part, at least 2 are missing
9620 : !
9621 : Select Case (JHIG)
9622 : !!!!! CASE DEFAULT
9623 : !!!!! write (*,*) "Assertion failed"
9624 : !!!!! STOP
9625 : !
9626 : ! We make a special case when we have so few values in
9627 : ! the high values set that it is bad performance to choose a pivot
9628 : ! and apply the general algorithm.
9629 : !
9630 : Case (2)
9631 0 : If (XDONT(IHIGT(1)) <= XDONT(IHIGT(2))) Then
9632 0 : JLOW = JLOW + 1
9633 0 : ILOWT (JLOW) = IHIGT (1)
9634 0 : JLOW = JLOW + 1
9635 0 : ILOWT (JLOW) = IHIGT (2)
9636 : Else
9637 0 : JLOW = JLOW + 1
9638 0 : ILOWT (JLOW) = IHIGT (2)
9639 0 : JLOW = JLOW + 1
9640 0 : ILOWT (JLOW) = IHIGT (1)
9641 : End If
9642 : Exit
9643 : !
9644 : Case (3)
9645 : !
9646 : !
9647 0 : IWRK1 = IHIGT (1)
9648 0 : IWRK2 = IHIGT (2)
9649 0 : IWRK3 = IHIGT (3)
9650 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
9651 0 : IHIGT (1) = IWRK2
9652 0 : IHIGT (2) = IWRK1
9653 0 : IWRK2 = IWRK1
9654 : End If
9655 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
9656 0 : IHIGT (3) = IWRK2
9657 0 : IHIGT (2) = IWRK3
9658 0 : IWRK2 = IWRK3
9659 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
9660 0 : IHIGT (2) = IHIGT (1)
9661 0 : IHIGT (1) = IWRK2
9662 : End If
9663 : End If
9664 0 : JHIG = 0
9665 0 : Do ICRS = JLOW + 1, NORD
9666 0 : JHIG = JHIG + 1
9667 0 : ILOWT (ICRS) = IHIGT (JHIG)
9668 : End Do
9669 0 : JLOW = NORD
9670 : Exit
9671 : !
9672 : Case (4 :)
9673 : !
9674 : !
9675 0 : XPIV0 = XPIV
9676 0 : IFIN = JHIG
9677 : !
9678 : ! One chooses a pivot from the 2 first values and the last one.
9679 : ! This should ensure sufficient renewal between iterations to
9680 : ! avoid worst case behavior effects.
9681 : !
9682 0 : IWRK1 = IHIGT (1)
9683 0 : IWRK2 = IHIGT (2)
9684 0 : IWRK3 = IHIGT (IFIN)
9685 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
9686 0 : IHIGT (1) = IWRK2
9687 0 : IHIGT (2) = IWRK1
9688 0 : IWRK2 = IWRK1
9689 : End If
9690 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
9691 0 : IHIGT (IFIN) = IWRK2
9692 0 : IHIGT (2) = IWRK3
9693 0 : IWRK2 = IWRK3
9694 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
9695 0 : IHIGT (2) = IHIGT (1)
9696 0 : IHIGT (1) = IWRK2
9697 : End If
9698 : End If
9699 : !
9700 0 : JDEB = JLOW
9701 0 : NWRK = NORD - JLOW
9702 0 : IWRK1 = IHIGT (1)
9703 0 : JLOW = JLOW + 1
9704 0 : ILOWT (JLOW) = IWRK1
9705 0 : XPIV = XDONT (IWRK1) + REAL(NWRK, dp) / REAL(NORD + NWRK, dp) * &
9706 0 : (XDONT(IHIGT(IFIN)) - XDONT(IWRK1))
9707 : !
9708 : ! One takes values <= pivot to ILOWT
9709 : ! Again, 2 parts, one where we take care of the remaining
9710 : ! high values because we might still need them, and the
9711 : ! other when we know that we will have more than enough
9712 : ! low values in the end.
9713 : !
9714 0 : JHIG = 0
9715 0 : Do ICRS = 2, IFIN
9716 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
9717 0 : JLOW = JLOW + 1
9718 0 : ILOWT (JLOW) = IHIGT (ICRS)
9719 0 : If (JLOW >= NORD) Exit
9720 : Else
9721 0 : JHIG = JHIG + 1
9722 0 : IHIGT (JHIG) = IHIGT (ICRS)
9723 : End If
9724 : End Do
9725 : !
9726 0 : Do ICRS = ICRS + 1, IFIN
9727 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
9728 0 : JLOW = JLOW + 1
9729 0 : ILOWT (JLOW) = IHIGT (ICRS)
9730 : End If
9731 : End Do
9732 : End Select
9733 : !
9734 : !
9735 : Case (1)
9736 : !
9737 : ! Only 1 value is missing in low part
9738 : !
9739 0 : XMIN = XDONT (IHIGT(1))
9740 0 : IHIG = 1
9741 0 : Do ICRS = 2, JHIG
9742 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
9743 0 : XMIN = XDONT (IHIGT(ICRS))
9744 0 : IHIG = ICRS
9745 : End If
9746 : End Do
9747 : !
9748 0 : JLOW = JLOW + 1
9749 0 : ILOWT (JLOW) = IHIGT (IHIG)
9750 0 : Exit
9751 : !
9752 : !
9753 : Case (0)
9754 : !
9755 : ! Low part is exactly what we want
9756 : !
9757 0 : Exit
9758 : !
9759 : !
9760 : Case (-5 : -1)
9761 : !
9762 : ! Only few values too many in low part
9763 : !
9764 0 : IRNGT (1) = ILOWT (1)
9765 0 : Do ICRS = 2, NORD
9766 0 : IWRK = ILOWT (ICRS)
9767 0 : XWRK = XDONT (IWRK)
9768 0 : Do IDCR = ICRS - 1, 1, - 1
9769 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
9770 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
9771 : Else
9772 : Exit
9773 : End If
9774 : End Do
9775 0 : IRNGT (IDCR + 1) = IWRK
9776 : End Do
9777 : !
9778 0 : XWRK1 = XDONT (IRNGT(NORD))
9779 0 : Do ICRS = NORD + 1, JLOW
9780 0 : If (XDONT(ILOWT (ICRS)) < XWRK1) Then
9781 0 : XWRK = XDONT (ILOWT (ICRS))
9782 0 : Do IDCR = NORD - 1, 1, - 1
9783 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
9784 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
9785 : End Do
9786 0 : IRNGT (IDCR + 1) = ILOWT (ICRS)
9787 0 : XWRK1 = XDONT (IRNGT(NORD))
9788 : End If
9789 : End Do
9790 : !
9791 0 : Return
9792 : !
9793 : !
9794 : Case (: -6)
9795 : !
9796 : ! last case: too many values in low part
9797 : !
9798 0 : IDEB = JDEB + 1
9799 0 : IMIL = (JLOW + IDEB) / 2
9800 0 : IFIN = JLOW
9801 : !
9802 : ! One chooses a pivot from 1st, last, and middle values
9803 : !
9804 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
9805 0 : IWRK = ILOWT (IDEB)
9806 0 : ILOWT (IDEB) = ILOWT (IMIL)
9807 0 : ILOWT (IMIL) = IWRK
9808 : End If
9809 0 : If (XDONT(ILOWT(IMIL)) > XDONT(ILOWT(IFIN))) Then
9810 0 : IWRK = ILOWT (IFIN)
9811 0 : ILOWT (IFIN) = ILOWT (IMIL)
9812 0 : ILOWT (IMIL) = IWRK
9813 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
9814 0 : IWRK = ILOWT (IDEB)
9815 0 : ILOWT (IDEB) = ILOWT (IMIL)
9816 0 : ILOWT (IMIL) = IWRK
9817 : End If
9818 : End If
9819 0 : If (IFIN <= 3) Exit
9820 : !
9821 0 : XPIV = XDONT (ILOWT(1)) + REAL(NORD, dp) / REAL(JLOW + NORD, dp) * &
9822 0 : (XDONT(ILOWT(IFIN)) - XDONT(ILOWT(1)))
9823 0 : If (JDEB > 0) Then
9824 0 : If (XPIV <= XPIV0) &
9825 : XPIV = XPIV0 + REAL(2 * NORD - JDEB, dp) / REAL(JLOW + NORD, dp) * &
9826 0 : (XDONT(ILOWT(IFIN)) - XPIV0)
9827 : Else
9828 : IDEB = 1
9829 : End If
9830 : !
9831 : ! One takes values > XPIV to IHIGT
9832 : ! However, we do not process the first values if we have been
9833 : ! through the case when we did not have enough low values
9834 : !
9835 0 : JHIG = 0
9836 0 : JLOW = JDEB
9837 : !
9838 0 : If (XDONT(ILOWT(IFIN)) > XPIV) Then
9839 : ICRS = JDEB
9840 : Do
9841 0 : ICRS = ICRS + 1
9842 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
9843 0 : JHIG = JHIG + 1
9844 0 : IHIGT (JHIG) = ILOWT (ICRS)
9845 0 : If (ICRS >= IFIN) Exit
9846 : Else
9847 0 : JLOW = JLOW + 1
9848 0 : ILOWT (JLOW) = ILOWT (ICRS)
9849 0 : If (JLOW >= NORD) Exit
9850 : End If
9851 : End Do
9852 : !
9853 0 : If (ICRS < IFIN) Then
9854 : Do
9855 0 : ICRS = ICRS + 1
9856 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
9857 0 : JLOW = JLOW + 1
9858 0 : ILOWT (JLOW) = ILOWT (ICRS)
9859 : Else
9860 0 : If (ICRS >= IFIN) Exit
9861 : End If
9862 : End Do
9863 : End If
9864 : Else
9865 0 : Do ICRS = IDEB, IFIN
9866 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
9867 0 : JHIG = JHIG + 1
9868 0 : IHIGT (JHIG) = ILOWT (ICRS)
9869 : Else
9870 0 : JLOW = JLOW + 1
9871 0 : ILOWT (JLOW) = ILOWT (ICRS)
9872 0 : If (JLOW >= NORD) Exit
9873 : End If
9874 : End Do
9875 : !
9876 0 : Do ICRS = ICRS + 1, IFIN
9877 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
9878 0 : JLOW = JLOW + 1
9879 0 : ILOWT (JLOW) = ILOWT (ICRS)
9880 : End If
9881 : End Do
9882 : End If
9883 : !
9884 : End Select
9885 : !
9886 : End Do
9887 : !
9888 : ! Now, we only need to complete ranking of the 1:NORD set
9889 : ! Assuming NORD is small, we use a simple insertion sort
9890 : !
9891 0 : IRNGT (1) = ILOWT (1)
9892 0 : Do ICRS = 2, NORD
9893 0 : IWRK = ILOWT (ICRS)
9894 0 : XWRK = XDONT (IWRK)
9895 0 : Do IDCR = ICRS - 1, 1, - 1
9896 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
9897 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
9898 : Else
9899 : Exit
9900 : End If
9901 : End Do
9902 0 : IRNGT (IDCR + 1) = IWRK
9903 : End Do
9904 : Return
9905 : !
9906 : !
9907 0 : End Subroutine D_rnkpar
9908 :
9909 0 : Subroutine R_rnkpar (XDONT, IRNGT, NORD)
9910 : ! Ranks partially XDONT by IRNGT, up to order NORD
9911 : ! __________________________________________________________
9912 : ! This routine uses a pivoting strategy such as the one of
9913 : ! finding the median based on the quicksort algorithm, but
9914 : ! we skew the pivot choice to try to bring it to NORD as
9915 : ! fast as possible. It uses 2 temporary arrays, where it
9916 : ! stores the indices of the values smaller than the pivot
9917 : ! (ILOWT), and the indices of values larger than the pivot
9918 : ! that we might still need later on (IHIGT). It iterates
9919 : ! until it can bring the number of values in ILOWT to
9920 : ! exactly NORD, and then uses an insertion sort to rank
9921 : ! this set, since it is supposedly small.
9922 : ! Michel Olagnon - Feb. 2000
9923 : ! __________________________________________________________
9924 : ! _________________________________________________________
9925 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
9926 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
9927 : Integer(kind = i4), Intent (In) :: NORD
9928 : ! __________________________________________________________
9929 0 : Real(kind = sp) :: XPIV, XPIV0, XWRK, XWRK1, XMIN, XMAX
9930 : !
9931 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
9932 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
9933 : Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
9934 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
9935 : !
9936 0 : NDON = SIZE (XDONT)
9937 : !
9938 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
9939 : !
9940 0 : If (NDON < 2) Then
9941 0 : If (NORD >= 1) IRNGT (1) = 1
9942 0 : Return
9943 : End If
9944 : !
9945 : ! One chooses a pivot, best estimate possible to put fractile near
9946 : ! mid-point of the set of low values.
9947 : !
9948 0 : If (XDONT(2) < XDONT(1)) Then
9949 0 : ILOWT (1) = 2
9950 0 : IHIGT (1) = 1
9951 : Else
9952 0 : ILOWT (1) = 1
9953 0 : IHIGT (1) = 2
9954 : End If
9955 : !
9956 0 : If (NDON < 3) Then
9957 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
9958 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
9959 0 : Return
9960 : End If
9961 : !
9962 0 : If (XDONT(3) <= XDONT(IHIGT(1))) Then
9963 0 : IHIGT (2) = IHIGT (1)
9964 0 : If (XDONT(3) < XDONT(ILOWT(1))) Then
9965 0 : IHIGT (1) = ILOWT (1)
9966 0 : ILOWT (1) = 3
9967 : Else
9968 0 : IHIGT (1) = 3
9969 : End If
9970 : Else
9971 0 : IHIGT (2) = 3
9972 : End If
9973 : !
9974 0 : If (NDON < 4) Then
9975 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
9976 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
9977 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
9978 0 : Return
9979 : End If
9980 : !
9981 0 : If (XDONT(NDON) <= XDONT(IHIGT(1))) Then
9982 0 : IHIGT (3) = IHIGT (2)
9983 0 : IHIGT (2) = IHIGT (1)
9984 0 : If (XDONT(NDON) < XDONT(ILOWT(1))) Then
9985 0 : IHIGT (1) = ILOWT (1)
9986 0 : ILOWT (1) = NDON
9987 : Else
9988 0 : IHIGT (1) = NDON
9989 : End If
9990 : Else
9991 0 : if (XDONT (NDON) < XDONT (IHIGT(2))) Then
9992 0 : IHIGT (3) = IHIGT (2)
9993 0 : IHIGT (2) = NDON
9994 : else
9995 0 : IHIGT (3) = NDON
9996 : end if
9997 : End If
9998 : !
9999 0 : If (NDON < 5) Then
10000 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
10001 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
10002 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
10003 0 : If (NORD >= 4) IRNGT (4) = IHIGT (3)
10004 0 : Return
10005 : End If
10006 : !
10007 0 : JDEB = 0
10008 0 : IDEB = JDEB + 1
10009 0 : JLOW = IDEB
10010 0 : JHIG = 3
10011 0 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, sp) / REAL(NDON + NORD, sp) * &
10012 0 : (XDONT(IHIGT(3)) - XDONT(ILOWT(IDEB)))
10013 0 : If (XPIV >= XDONT(IHIGT(1))) Then
10014 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, sp) / REAL(NDON + NORD, sp) * &
10015 0 : (XDONT(IHIGT(2)) - XDONT(ILOWT(IDEB)))
10016 0 : If (XPIV >= XDONT(IHIGT(1))) &
10017 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, sp) / REAL(NDON + NORD, sp) * &
10018 0 : (XDONT(IHIGT(1)) - XDONT(ILOWT(IDEB)))
10019 : End If
10020 0 : XPIV0 = XPIV
10021 : !
10022 : ! One puts values > pivot in the end and those <= pivot
10023 : ! at the beginning. This is split in 2 cases, so that
10024 : ! we can skip the loop test a number of times.
10025 : ! As we are also filling in the work arrays at the same time
10026 : ! we stop filling in the IHIGT array as soon as we have more
10027 : ! than enough values in ILOWT.
10028 : !
10029 : !
10030 0 : If (XDONT(NDON) > XPIV) Then
10031 : ICRS = 3
10032 : Do
10033 0 : ICRS = ICRS + 1
10034 0 : If (XDONT(ICRS) > XPIV) Then
10035 0 : If (ICRS >= NDON) Exit
10036 0 : JHIG = JHIG + 1
10037 0 : IHIGT (JHIG) = ICRS
10038 : Else
10039 0 : JLOW = JLOW + 1
10040 0 : ILOWT (JLOW) = ICRS
10041 0 : If (JLOW >= NORD) Exit
10042 : End If
10043 : End Do
10044 : !
10045 : ! One restricts further processing because it is no use
10046 : ! to store more high values
10047 : !
10048 0 : If (ICRS < NDON - 1) Then
10049 : Do
10050 0 : ICRS = ICRS + 1
10051 0 : If (XDONT(ICRS) <= XPIV) Then
10052 0 : JLOW = JLOW + 1
10053 0 : ILOWT (JLOW) = ICRS
10054 0 : Else If (ICRS >= NDON) Then
10055 : Exit
10056 : End If
10057 : End Do
10058 : End If
10059 : !
10060 : !
10061 : Else
10062 : !
10063 : ! Same as above, but this is not as easy to optimize, so the
10064 : ! DO-loop is kept
10065 : !
10066 0 : Do ICRS = 4, NDON - 1
10067 0 : If (XDONT(ICRS) > XPIV) Then
10068 0 : JHIG = JHIG + 1
10069 0 : IHIGT (JHIG) = ICRS
10070 : Else
10071 0 : JLOW = JLOW + 1
10072 0 : ILOWT (JLOW) = ICRS
10073 0 : If (JLOW >= NORD) Exit
10074 : End If
10075 : End Do
10076 : !
10077 0 : If (ICRS < NDON - 1) Then
10078 : Do
10079 0 : ICRS = ICRS + 1
10080 0 : If (XDONT(ICRS) <= XPIV) Then
10081 0 : If (ICRS >= NDON) Exit
10082 0 : JLOW = JLOW + 1
10083 0 : ILOWT (JLOW) = ICRS
10084 : End If
10085 : End Do
10086 : End If
10087 : End If
10088 : !
10089 : JLM2 = 0
10090 : JLM1 = 0
10091 : JHM2 = 0
10092 : JHM1 = 0
10093 : Do
10094 0 : if (JLOW == NORD) Exit
10095 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
10096 : !
10097 : ! We are oscillating. Perturbate by bringing JLOW closer by one
10098 : ! to NORD
10099 : !
10100 0 : If (NORD > JLOW) Then
10101 0 : XMIN = XDONT (IHIGT(1))
10102 0 : IHIG = 1
10103 0 : Do ICRS = 2, JHIG
10104 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
10105 0 : XMIN = XDONT (IHIGT(ICRS))
10106 0 : IHIG = ICRS
10107 : End If
10108 : End Do
10109 : !
10110 0 : JLOW = JLOW + 1
10111 0 : ILOWT (JLOW) = IHIGT (IHIG)
10112 0 : IHIGT (IHIG) = IHIGT (JHIG)
10113 0 : JHIG = JHIG - 1
10114 : Else
10115 0 : ILOW = ILOWT (JLOW)
10116 0 : XMAX = XDONT (ILOW)
10117 0 : Do ICRS = 1, JLOW
10118 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
10119 0 : IWRK = ILOWT (ICRS)
10120 0 : XMAX = XDONT (IWRK)
10121 0 : ILOWT (ICRS) = ILOW
10122 0 : ILOW = IWRK
10123 : End If
10124 : End Do
10125 0 : JLOW = JLOW - 1
10126 : End If
10127 : End If
10128 0 : JLM2 = JLM1
10129 0 : JLM1 = JLOW
10130 0 : JHM2 = JHM1
10131 0 : JHM1 = JHIG
10132 : !
10133 : ! We try to bring the number of values in the low values set
10134 : ! closer to NORD.
10135 : !
10136 0 : Select Case (NORD - JLOW)
10137 : Case (2 :)
10138 : !
10139 : ! Not enough values in low part, at least 2 are missing
10140 : !
10141 : Select Case (JHIG)
10142 : !!!!! CASE DEFAULT
10143 : !!!!! write (*,*) "Assertion failed"
10144 : !!!!! STOP
10145 : !
10146 : ! We make a special case when we have so few values in
10147 : ! the high values set that it is bad performance to choose a pivot
10148 : ! and apply the general algorithm.
10149 : !
10150 : Case (2)
10151 0 : If (XDONT(IHIGT(1)) <= XDONT(IHIGT(2))) Then
10152 0 : JLOW = JLOW + 1
10153 0 : ILOWT (JLOW) = IHIGT (1)
10154 0 : JLOW = JLOW + 1
10155 0 : ILOWT (JLOW) = IHIGT (2)
10156 : Else
10157 0 : JLOW = JLOW + 1
10158 0 : ILOWT (JLOW) = IHIGT (2)
10159 0 : JLOW = JLOW + 1
10160 0 : ILOWT (JLOW) = IHIGT (1)
10161 : End If
10162 : Exit
10163 : !
10164 : Case (3)
10165 : !
10166 : !
10167 0 : IWRK1 = IHIGT (1)
10168 0 : IWRK2 = IHIGT (2)
10169 0 : IWRK3 = IHIGT (3)
10170 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
10171 0 : IHIGT (1) = IWRK2
10172 0 : IHIGT (2) = IWRK1
10173 0 : IWRK2 = IWRK1
10174 : End If
10175 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
10176 0 : IHIGT (3) = IWRK2
10177 0 : IHIGT (2) = IWRK3
10178 0 : IWRK2 = IWRK3
10179 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
10180 0 : IHIGT (2) = IHIGT (1)
10181 0 : IHIGT (1) = IWRK2
10182 : End If
10183 : End If
10184 0 : JHIG = 0
10185 0 : Do ICRS = JLOW + 1, NORD
10186 0 : JHIG = JHIG + 1
10187 0 : ILOWT (ICRS) = IHIGT (JHIG)
10188 : End Do
10189 0 : JLOW = NORD
10190 : Exit
10191 : !
10192 : Case (4 :)
10193 : !
10194 : !
10195 0 : XPIV0 = XPIV
10196 0 : IFIN = JHIG
10197 : !
10198 : ! One chooses a pivot from the 2 first values and the last one.
10199 : ! This should ensure sufficient renewal between iterations to
10200 : ! avoid worst case behavior effects.
10201 : !
10202 0 : IWRK1 = IHIGT (1)
10203 0 : IWRK2 = IHIGT (2)
10204 0 : IWRK3 = IHIGT (IFIN)
10205 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
10206 0 : IHIGT (1) = IWRK2
10207 0 : IHIGT (2) = IWRK1
10208 0 : IWRK2 = IWRK1
10209 : End If
10210 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
10211 0 : IHIGT (IFIN) = IWRK2
10212 0 : IHIGT (2) = IWRK3
10213 0 : IWRK2 = IWRK3
10214 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
10215 0 : IHIGT (2) = IHIGT (1)
10216 0 : IHIGT (1) = IWRK2
10217 : End If
10218 : End If
10219 : !
10220 0 : JDEB = JLOW
10221 0 : NWRK = NORD - JLOW
10222 0 : IWRK1 = IHIGT (1)
10223 0 : JLOW = JLOW + 1
10224 0 : ILOWT (JLOW) = IWRK1
10225 0 : XPIV = XDONT (IWRK1) + REAL(NWRK, sp) / REAL(NORD + NWRK, sp) * &
10226 0 : (XDONT(IHIGT(IFIN)) - XDONT(IWRK1))
10227 : !
10228 : ! One takes values <= pivot to ILOWT
10229 : ! Again, 2 parts, one where we take care of the remaining
10230 : ! high values because we might still need them, and the
10231 : ! other when we know that we will have more than enough
10232 : ! low values in the end.
10233 : !
10234 0 : JHIG = 0
10235 0 : Do ICRS = 2, IFIN
10236 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
10237 0 : JLOW = JLOW + 1
10238 0 : ILOWT (JLOW) = IHIGT (ICRS)
10239 0 : If (JLOW >= NORD) Exit
10240 : Else
10241 0 : JHIG = JHIG + 1
10242 0 : IHIGT (JHIG) = IHIGT (ICRS)
10243 : End If
10244 : End Do
10245 : !
10246 0 : Do ICRS = ICRS + 1, IFIN
10247 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
10248 0 : JLOW = JLOW + 1
10249 0 : ILOWT (JLOW) = IHIGT (ICRS)
10250 : End If
10251 : End Do
10252 : End Select
10253 : !
10254 : !
10255 : Case (1)
10256 : !
10257 : ! Only 1 value is missing in low part
10258 : !
10259 0 : XMIN = XDONT (IHIGT(1))
10260 0 : IHIG = 1
10261 0 : Do ICRS = 2, JHIG
10262 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
10263 0 : XMIN = XDONT (IHIGT(ICRS))
10264 0 : IHIG = ICRS
10265 : End If
10266 : End Do
10267 : !
10268 0 : JLOW = JLOW + 1
10269 0 : ILOWT (JLOW) = IHIGT (IHIG)
10270 0 : Exit
10271 : !
10272 : !
10273 : Case (0)
10274 : !
10275 : ! Low part is exactly what we want
10276 : !
10277 0 : Exit
10278 : !
10279 : !
10280 : Case (-5 : -1)
10281 : !
10282 : ! Only few values too many in low part
10283 : !
10284 0 : IRNGT (1) = ILOWT (1)
10285 0 : Do ICRS = 2, NORD
10286 0 : IWRK = ILOWT (ICRS)
10287 0 : XWRK = XDONT (IWRK)
10288 0 : Do IDCR = ICRS - 1, 1, - 1
10289 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
10290 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
10291 : Else
10292 : Exit
10293 : End If
10294 : End Do
10295 0 : IRNGT (IDCR + 1) = IWRK
10296 : End Do
10297 : !
10298 0 : XWRK1 = XDONT (IRNGT(NORD))
10299 0 : Do ICRS = NORD + 1, JLOW
10300 0 : If (XDONT(ILOWT (ICRS)) < XWRK1) Then
10301 0 : XWRK = XDONT (ILOWT (ICRS))
10302 0 : Do IDCR = NORD - 1, 1, - 1
10303 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
10304 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
10305 : End Do
10306 0 : IRNGT (IDCR + 1) = ILOWT (ICRS)
10307 0 : XWRK1 = XDONT (IRNGT(NORD))
10308 : End If
10309 : End Do
10310 : !
10311 0 : Return
10312 : !
10313 : !
10314 : Case (: -6)
10315 : !
10316 : ! last case: too many values in low part
10317 : !
10318 0 : IDEB = JDEB + 1
10319 0 : IMIL = (JLOW + IDEB) / 2
10320 0 : IFIN = JLOW
10321 : !
10322 : ! One chooses a pivot from 1st, last, and middle values
10323 : !
10324 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
10325 0 : IWRK = ILOWT (IDEB)
10326 0 : ILOWT (IDEB) = ILOWT (IMIL)
10327 0 : ILOWT (IMIL) = IWRK
10328 : End If
10329 0 : If (XDONT(ILOWT(IMIL)) > XDONT(ILOWT(IFIN))) Then
10330 0 : IWRK = ILOWT (IFIN)
10331 0 : ILOWT (IFIN) = ILOWT (IMIL)
10332 0 : ILOWT (IMIL) = IWRK
10333 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
10334 0 : IWRK = ILOWT (IDEB)
10335 0 : ILOWT (IDEB) = ILOWT (IMIL)
10336 0 : ILOWT (IMIL) = IWRK
10337 : End If
10338 : End If
10339 0 : If (IFIN <= 3) Exit
10340 : !
10341 0 : XPIV = XDONT (ILOWT(1)) + REAL(NORD, sp) / REAL(JLOW + NORD, sp) * &
10342 0 : (XDONT(ILOWT(IFIN)) - XDONT(ILOWT(1)))
10343 0 : If (JDEB > 0) Then
10344 0 : If (XPIV <= XPIV0) &
10345 : XPIV = XPIV0 + REAL(2 * NORD - JDEB, sp) / REAL(JLOW + NORD, sp) * &
10346 0 : (XDONT(ILOWT(IFIN)) - XPIV0)
10347 : Else
10348 : IDEB = 1
10349 : End If
10350 : !
10351 : ! One takes values > XPIV to IHIGT
10352 : ! However, we do not process the first values if we have been
10353 : ! through the case when we did not have enough low values
10354 : !
10355 0 : JHIG = 0
10356 0 : JLOW = JDEB
10357 : !
10358 0 : If (XDONT(ILOWT(IFIN)) > XPIV) Then
10359 : ICRS = JDEB
10360 : Do
10361 0 : ICRS = ICRS + 1
10362 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
10363 0 : JHIG = JHIG + 1
10364 0 : IHIGT (JHIG) = ILOWT (ICRS)
10365 0 : If (ICRS >= IFIN) Exit
10366 : Else
10367 0 : JLOW = JLOW + 1
10368 0 : ILOWT (JLOW) = ILOWT (ICRS)
10369 0 : If (JLOW >= NORD) Exit
10370 : End If
10371 : End Do
10372 : !
10373 0 : If (ICRS < IFIN) Then
10374 : Do
10375 0 : ICRS = ICRS + 1
10376 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
10377 0 : JLOW = JLOW + 1
10378 0 : ILOWT (JLOW) = ILOWT (ICRS)
10379 : Else
10380 0 : If (ICRS >= IFIN) Exit
10381 : End If
10382 : End Do
10383 : End If
10384 : Else
10385 0 : Do ICRS = IDEB, IFIN
10386 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
10387 0 : JHIG = JHIG + 1
10388 0 : IHIGT (JHIG) = ILOWT (ICRS)
10389 : Else
10390 0 : JLOW = JLOW + 1
10391 0 : ILOWT (JLOW) = ILOWT (ICRS)
10392 0 : If (JLOW >= NORD) Exit
10393 : End If
10394 : End Do
10395 : !
10396 0 : Do ICRS = ICRS + 1, IFIN
10397 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
10398 0 : JLOW = JLOW + 1
10399 0 : ILOWT (JLOW) = ILOWT (ICRS)
10400 : End If
10401 : End Do
10402 : End If
10403 : !
10404 : End Select
10405 : !
10406 : End Do
10407 : !
10408 : ! Now, we only need to complete ranking of the 1:NORD set
10409 : ! Assuming NORD is small, we use a simple insertion sort
10410 : !
10411 0 : IRNGT (1) = ILOWT (1)
10412 0 : Do ICRS = 2, NORD
10413 0 : IWRK = ILOWT (ICRS)
10414 0 : XWRK = XDONT (IWRK)
10415 0 : Do IDCR = ICRS - 1, 1, - 1
10416 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
10417 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
10418 : Else
10419 : Exit
10420 : End If
10421 : End Do
10422 0 : IRNGT (IDCR + 1) = IWRK
10423 : End Do
10424 : Return
10425 : !
10426 : !
10427 0 : End Subroutine R_rnkpar
10428 :
10429 0 : Subroutine I_rnkpar (XDONT, IRNGT, NORD)
10430 : ! Ranks partially XDONT by IRNGT, up to order NORD
10431 : ! __________________________________________________________
10432 : ! This routine uses a pivoting strategy such as the one of
10433 : ! finding the median based on the quicksort algorithm, but
10434 : ! we skew the pivot choice to try to bring it to NORD as
10435 : ! fast as possible. It uses 2 temporary arrays, where it
10436 : ! stores the indices of the values smaller than the pivot
10437 : ! (ILOWT), and the indices of values larger than the pivot
10438 : ! that we might still need later on (IHIGT). It iterates
10439 : ! until it can bring the number of values in ILOWT to
10440 : ! exactly NORD, and then uses an insertion sort to rank
10441 : ! this set, since it is supposedly small.
10442 : ! Michel Olagnon - Feb. 2000
10443 : ! __________________________________________________________
10444 : ! __________________________________________________________
10445 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
10446 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
10447 : Integer(kind = i4), Intent (In) :: NORD
10448 : ! __________________________________________________________
10449 : Integer(kind = i4) :: XPIV, XPIV0, XWRK, XWRK1, XMIN, XMAX
10450 : !
10451 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
10452 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
10453 : Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
10454 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
10455 : !
10456 0 : NDON = SIZE (XDONT)
10457 : !
10458 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
10459 : !
10460 0 : If (NDON < 2) Then
10461 0 : If (NORD >= 1) IRNGT (1) = 1
10462 0 : Return
10463 : End If
10464 : !
10465 : ! One chooses a pivot, best estimate possible to put fractile near
10466 : ! mid-point of the set of low values.
10467 : !
10468 0 : If (XDONT(2) < XDONT(1)) Then
10469 0 : ILOWT (1) = 2
10470 0 : IHIGT (1) = 1
10471 : Else
10472 0 : ILOWT (1) = 1
10473 0 : IHIGT (1) = 2
10474 : End If
10475 : !
10476 0 : If (NDON < 3) Then
10477 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
10478 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
10479 0 : Return
10480 : End If
10481 : !
10482 0 : If (XDONT(3) <= XDONT(IHIGT(1))) Then
10483 0 : IHIGT (2) = IHIGT (1)
10484 0 : If (XDONT(3) < XDONT(ILOWT(1))) Then
10485 0 : IHIGT (1) = ILOWT (1)
10486 0 : ILOWT (1) = 3
10487 : Else
10488 0 : IHIGT (1) = 3
10489 : End If
10490 : Else
10491 0 : IHIGT (2) = 3
10492 : End If
10493 : !
10494 0 : If (NDON < 4) Then
10495 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
10496 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
10497 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
10498 0 : Return
10499 : End If
10500 : !
10501 0 : If (XDONT(NDON) <= XDONT(IHIGT(1))) Then
10502 0 : IHIGT (3) = IHIGT (2)
10503 0 : IHIGT (2) = IHIGT (1)
10504 0 : If (XDONT(NDON) < XDONT(ILOWT(1))) Then
10505 0 : IHIGT (1) = ILOWT (1)
10506 0 : ILOWT (1) = NDON
10507 : Else
10508 0 : IHIGT (1) = NDON
10509 : End If
10510 : Else
10511 0 : if (XDONT (NDON) < XDONT (IHIGT(2))) Then
10512 0 : IHIGT (3) = IHIGT (2)
10513 0 : IHIGT (2) = NDON
10514 : else
10515 0 : IHIGT (3) = NDON
10516 : end if
10517 : End If
10518 : !
10519 0 : If (NDON < 5) Then
10520 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
10521 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
10522 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
10523 0 : If (NORD >= 4) IRNGT (4) = IHIGT (3)
10524 0 : Return
10525 : End If
10526 : !
10527 0 : JDEB = 0
10528 0 : IDEB = JDEB + 1
10529 0 : JLOW = IDEB
10530 0 : JHIG = 3
10531 0 : XPIV = XDONT (ILOWT(IDEB)) + INT(REAL(2 * NORD, sp) / REAL(NDON + NORD, sp), i4) * &
10532 0 : (XDONT(IHIGT(3)) - XDONT(ILOWT(IDEB)))
10533 0 : If (XPIV >= XDONT(IHIGT(1))) Then
10534 : XPIV = XDONT (ILOWT(IDEB)) + INT(REAL(2 * NORD, sp) / REAL(NDON + NORD, sp), i4) * &
10535 0 : (XDONT(IHIGT(2)) - XDONT(ILOWT(IDEB)))
10536 0 : If (XPIV >= XDONT(IHIGT(1))) &
10537 : XPIV = XDONT (ILOWT(IDEB)) + INT(REAL(2 * NORD, sp) / REAL(NDON + NORD, sp), i4) * &
10538 0 : (XDONT(IHIGT(1)) - XDONT(ILOWT(IDEB)))
10539 : End If
10540 0 : XPIV0 = XPIV
10541 : !
10542 : ! One puts values > pivot in the end and those <= pivot
10543 : ! at the beginning. This is split in 2 cases, so that
10544 : ! we can skip the loop test a number of times.
10545 : ! As we are also filling in the work arrays at the same time
10546 : ! we stop filling in the IHIGT array as soon as we have more
10547 : ! than enough values in ILOWT.
10548 : !
10549 : !
10550 0 : If (XDONT(NDON) > XPIV) Then
10551 : ICRS = 3
10552 : Do
10553 0 : ICRS = ICRS + 1
10554 0 : If (XDONT(ICRS) > XPIV) Then
10555 0 : If (ICRS >= NDON) Exit
10556 0 : JHIG = JHIG + 1
10557 0 : IHIGT (JHIG) = ICRS
10558 : Else
10559 0 : JLOW = JLOW + 1
10560 0 : ILOWT (JLOW) = ICRS
10561 0 : If (JLOW >= NORD) Exit
10562 : End If
10563 : End Do
10564 : !
10565 : ! One restricts further processing because it is no use
10566 : ! to store more high values
10567 : !
10568 0 : If (ICRS < NDON - 1) Then
10569 : Do
10570 0 : ICRS = ICRS + 1
10571 0 : If (XDONT(ICRS) <= XPIV) Then
10572 0 : JLOW = JLOW + 1
10573 0 : ILOWT (JLOW) = ICRS
10574 0 : Else If (ICRS >= NDON) Then
10575 : Exit
10576 : End If
10577 : End Do
10578 : End If
10579 : !
10580 : !
10581 : Else
10582 : !
10583 : ! Same as above, but this is not as easy to optimize, so the
10584 : ! DO-loop is kept
10585 : !
10586 0 : Do ICRS = 4, NDON - 1
10587 0 : If (XDONT(ICRS) > XPIV) Then
10588 0 : JHIG = JHIG + 1
10589 0 : IHIGT (JHIG) = ICRS
10590 : Else
10591 0 : JLOW = JLOW + 1
10592 0 : ILOWT (JLOW) = ICRS
10593 0 : If (JLOW >= NORD) Exit
10594 : End If
10595 : End Do
10596 : !
10597 0 : If (ICRS < NDON - 1) Then
10598 : Do
10599 0 : ICRS = ICRS + 1
10600 0 : If (XDONT(ICRS) <= XPIV) Then
10601 0 : If (ICRS >= NDON) Exit
10602 0 : JLOW = JLOW + 1
10603 0 : ILOWT (JLOW) = ICRS
10604 : End If
10605 : End Do
10606 : End If
10607 : End If
10608 : !
10609 : JLM2 = 0
10610 : JLM1 = 0
10611 : JHM2 = 0
10612 : JHM1 = 0
10613 : Do
10614 0 : if (JLOW == NORD) Exit
10615 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
10616 : !
10617 : ! We are oscillating. Perturbate by bringing JLOW closer by one
10618 : ! to NORD
10619 : !
10620 0 : If (NORD > JLOW) Then
10621 0 : XMIN = XDONT (IHIGT(1))
10622 0 : IHIG = 1
10623 0 : Do ICRS = 2, JHIG
10624 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
10625 0 : XMIN = XDONT (IHIGT(ICRS))
10626 0 : IHIG = ICRS
10627 : End If
10628 : End Do
10629 : !
10630 0 : JLOW = JLOW + 1
10631 0 : ILOWT (JLOW) = IHIGT (IHIG)
10632 0 : IHIGT (IHIG) = IHIGT (JHIG)
10633 0 : JHIG = JHIG - 1
10634 : Else
10635 0 : ILOW = ILOWT (JLOW)
10636 0 : XMAX = XDONT (ILOW)
10637 0 : Do ICRS = 1, JLOW
10638 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
10639 0 : IWRK = ILOWT (ICRS)
10640 0 : XMAX = XDONT (IWRK)
10641 0 : ILOWT (ICRS) = ILOW
10642 0 : ILOW = IWRK
10643 : End If
10644 : End Do
10645 0 : JLOW = JLOW - 1
10646 : End If
10647 : End If
10648 0 : JLM2 = JLM1
10649 0 : JLM1 = JLOW
10650 0 : JHM2 = JHM1
10651 0 : JHM1 = JHIG
10652 : !
10653 : ! We try to bring the number of values in the low values set
10654 : ! closer to NORD.
10655 : !
10656 0 : Select Case (NORD - JLOW)
10657 : Case (2 :)
10658 : !
10659 : ! Not enough values in low part, at least 2 are missing
10660 : !
10661 : Select Case (JHIG)
10662 : !!!!! CASE DEFAULT
10663 : !!!!! write (*,*) "Assertion failed"
10664 : !!!!! STOP
10665 : !
10666 : ! We make a special case when we have so few values in
10667 : ! the high values set that it is bad performance to choose a pivot
10668 : ! and apply the general algorithm.
10669 : !
10670 : Case (2)
10671 0 : If (XDONT(IHIGT(1)) <= XDONT(IHIGT(2))) Then
10672 0 : JLOW = JLOW + 1
10673 0 : ILOWT (JLOW) = IHIGT (1)
10674 0 : JLOW = JLOW + 1
10675 0 : ILOWT (JLOW) = IHIGT (2)
10676 : Else
10677 0 : JLOW = JLOW + 1
10678 0 : ILOWT (JLOW) = IHIGT (2)
10679 0 : JLOW = JLOW + 1
10680 0 : ILOWT (JLOW) = IHIGT (1)
10681 : End If
10682 : Exit
10683 : !
10684 : Case (3)
10685 : !
10686 : !
10687 0 : IWRK1 = IHIGT (1)
10688 0 : IWRK2 = IHIGT (2)
10689 0 : IWRK3 = IHIGT (3)
10690 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
10691 0 : IHIGT (1) = IWRK2
10692 0 : IHIGT (2) = IWRK1
10693 0 : IWRK2 = IWRK1
10694 : End If
10695 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
10696 0 : IHIGT (3) = IWRK2
10697 0 : IHIGT (2) = IWRK3
10698 0 : IWRK2 = IWRK3
10699 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
10700 0 : IHIGT (2) = IHIGT (1)
10701 0 : IHIGT (1) = IWRK2
10702 : End If
10703 : End If
10704 0 : JHIG = 0
10705 0 : Do ICRS = JLOW + 1, NORD
10706 0 : JHIG = JHIG + 1
10707 0 : ILOWT (ICRS) = IHIGT (JHIG)
10708 : End Do
10709 0 : JLOW = NORD
10710 : Exit
10711 : !
10712 : Case (4 :)
10713 : !
10714 : !
10715 0 : XPIV0 = XPIV
10716 0 : IFIN = JHIG
10717 : !
10718 : ! One chooses a pivot from the 2 first values and the last one.
10719 : ! This should ensure sufficient renewal between iterations to
10720 : ! avoid worst case behavior effects.
10721 : !
10722 0 : IWRK1 = IHIGT (1)
10723 0 : IWRK2 = IHIGT (2)
10724 0 : IWRK3 = IHIGT (IFIN)
10725 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
10726 0 : IHIGT (1) = IWRK2
10727 0 : IHIGT (2) = IWRK1
10728 0 : IWRK2 = IWRK1
10729 : End If
10730 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
10731 0 : IHIGT (IFIN) = IWRK2
10732 0 : IHIGT (2) = IWRK3
10733 0 : IWRK2 = IWRK3
10734 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
10735 0 : IHIGT (2) = IHIGT (1)
10736 0 : IHIGT (1) = IWRK2
10737 : End If
10738 : End If
10739 : !
10740 0 : JDEB = JLOW
10741 0 : NWRK = NORD - JLOW
10742 0 : IWRK1 = IHIGT (1)
10743 0 : JLOW = JLOW + 1
10744 0 : ILOWT (JLOW) = IWRK1
10745 0 : XPIV = XDONT (IWRK1) + INT(REAL(NWRK, sp) / REAL(NORD + NWRK, sp), i4) * &
10746 0 : (XDONT(IHIGT(IFIN)) - XDONT(IWRK1))
10747 : !
10748 : ! One takes values <= pivot to ILOWT
10749 : ! Again, 2 parts, one where we take care of the remaining
10750 : ! high values because we might still need them, and the
10751 : ! other when we know that we will have more than enough
10752 : ! low values in the end.
10753 : !
10754 0 : JHIG = 0
10755 0 : Do ICRS = 2, IFIN
10756 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
10757 0 : JLOW = JLOW + 1
10758 0 : ILOWT (JLOW) = IHIGT (ICRS)
10759 0 : If (JLOW >= NORD) Exit
10760 : Else
10761 0 : JHIG = JHIG + 1
10762 0 : IHIGT (JHIG) = IHIGT (ICRS)
10763 : End If
10764 : End Do
10765 : !
10766 0 : Do ICRS = ICRS + 1, IFIN
10767 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
10768 0 : JLOW = JLOW + 1
10769 0 : ILOWT (JLOW) = IHIGT (ICRS)
10770 : End If
10771 : End Do
10772 : End Select
10773 : !
10774 : !
10775 : Case (1)
10776 : !
10777 : ! Only 1 value is missing in low part
10778 : !
10779 0 : XMIN = XDONT (IHIGT(1))
10780 0 : IHIG = 1
10781 0 : Do ICRS = 2, JHIG
10782 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
10783 0 : XMIN = XDONT (IHIGT(ICRS))
10784 0 : IHIG = ICRS
10785 : End If
10786 : End Do
10787 : !
10788 0 : JLOW = JLOW + 1
10789 0 : ILOWT (JLOW) = IHIGT (IHIG)
10790 0 : Exit
10791 : !
10792 : !
10793 : Case (0)
10794 : !
10795 : ! Low part is exactly what we want
10796 : !
10797 0 : Exit
10798 : !
10799 : !
10800 : Case (-5 : -1)
10801 : !
10802 : ! Only few values too many in low part
10803 : !
10804 0 : IRNGT (1) = ILOWT (1)
10805 0 : Do ICRS = 2, NORD
10806 0 : IWRK = ILOWT (ICRS)
10807 0 : XWRK = XDONT (IWRK)
10808 0 : Do IDCR = ICRS - 1, 1, - 1
10809 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
10810 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
10811 : Else
10812 : Exit
10813 : End If
10814 : End Do
10815 0 : IRNGT (IDCR + 1) = IWRK
10816 : End Do
10817 : !
10818 0 : XWRK1 = XDONT (IRNGT(NORD))
10819 0 : Do ICRS = NORD + 1, JLOW
10820 0 : If (XDONT(ILOWT (ICRS)) < XWRK1) Then
10821 0 : XWRK = XDONT (ILOWT (ICRS))
10822 0 : Do IDCR = NORD - 1, 1, - 1
10823 0 : If (XWRK >= XDONT(IRNGT(IDCR))) Exit
10824 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
10825 : End Do
10826 0 : IRNGT (IDCR + 1) = ILOWT (ICRS)
10827 0 : XWRK1 = XDONT (IRNGT(NORD))
10828 : End If
10829 : End Do
10830 : !
10831 0 : Return
10832 : !
10833 : !
10834 : Case (: -6)
10835 : !
10836 : ! last case: too many values in low part
10837 : !
10838 0 : IDEB = JDEB + 1
10839 0 : IMIL = (JLOW + IDEB) / 2
10840 0 : IFIN = JLOW
10841 : !
10842 : ! One chooses a pivot from 1st, last, and middle values
10843 : !
10844 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
10845 0 : IWRK = ILOWT (IDEB)
10846 0 : ILOWT (IDEB) = ILOWT (IMIL)
10847 0 : ILOWT (IMIL) = IWRK
10848 : End If
10849 0 : If (XDONT(ILOWT(IMIL)) > XDONT(ILOWT(IFIN))) Then
10850 0 : IWRK = ILOWT (IFIN)
10851 0 : ILOWT (IFIN) = ILOWT (IMIL)
10852 0 : ILOWT (IMIL) = IWRK
10853 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
10854 0 : IWRK = ILOWT (IDEB)
10855 0 : ILOWT (IDEB) = ILOWT (IMIL)
10856 0 : ILOWT (IMIL) = IWRK
10857 : End If
10858 : End If
10859 0 : If (IFIN <= 3) Exit
10860 : !
10861 0 : XPIV = XDONT (ILOWT(1)) + INT(REAL(NORD, sp) / REAL(JLOW + NORD, sp), i4) * &
10862 0 : (XDONT(ILOWT(IFIN)) - XDONT(ILOWT(1)))
10863 0 : If (JDEB > 0) Then
10864 0 : If (XPIV <= XPIV0) &
10865 : XPIV = XPIV0 + INT(REAL(2 * NORD - JDEB, sp) / REAL(JLOW + NORD, sp), i4) * &
10866 0 : (XDONT(ILOWT(IFIN)) - XPIV0)
10867 : Else
10868 : IDEB = 1
10869 : End If
10870 : !
10871 : ! One takes values > XPIV to IHIGT
10872 : ! However, we do not process the first values if we have been
10873 : ! through the case when we did not have enough low values
10874 : !
10875 0 : JHIG = 0
10876 0 : JLOW = JDEB
10877 : !
10878 0 : If (XDONT(ILOWT(IFIN)) > XPIV) Then
10879 : ICRS = JDEB
10880 : Do
10881 0 : ICRS = ICRS + 1
10882 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
10883 0 : JHIG = JHIG + 1
10884 0 : IHIGT (JHIG) = ILOWT (ICRS)
10885 0 : If (ICRS >= IFIN) Exit
10886 : Else
10887 0 : JLOW = JLOW + 1
10888 0 : ILOWT (JLOW) = ILOWT (ICRS)
10889 0 : If (JLOW >= NORD) Exit
10890 : End If
10891 : End Do
10892 : !
10893 0 : If (ICRS < IFIN) Then
10894 : Do
10895 0 : ICRS = ICRS + 1
10896 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
10897 0 : JLOW = JLOW + 1
10898 0 : ILOWT (JLOW) = ILOWT (ICRS)
10899 : Else
10900 0 : If (ICRS >= IFIN) Exit
10901 : End If
10902 : End Do
10903 : End If
10904 : Else
10905 0 : Do ICRS = IDEB, IFIN
10906 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
10907 0 : JHIG = JHIG + 1
10908 0 : IHIGT (JHIG) = ILOWT (ICRS)
10909 : Else
10910 0 : JLOW = JLOW + 1
10911 0 : ILOWT (JLOW) = ILOWT (ICRS)
10912 0 : If (JLOW >= NORD) Exit
10913 : End If
10914 : End Do
10915 : !
10916 0 : Do ICRS = ICRS + 1, IFIN
10917 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
10918 0 : JLOW = JLOW + 1
10919 0 : ILOWT (JLOW) = ILOWT (ICRS)
10920 : End If
10921 : End Do
10922 : End If
10923 : !
10924 : End Select
10925 : !
10926 : End Do
10927 : !
10928 : ! Now, we only need to complete ranking of the 1:NORD set
10929 : ! Assuming NORD is small, we use a simple insertion sort
10930 : !
10931 0 : IRNGT (1) = ILOWT (1)
10932 0 : Do ICRS = 2, NORD
10933 0 : IWRK = ILOWT (ICRS)
10934 0 : XWRK = XDONT (IWRK)
10935 0 : Do IDCR = ICRS - 1, 1, - 1
10936 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
10937 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
10938 : Else
10939 : Exit
10940 : End If
10941 : End Do
10942 0 : IRNGT (IDCR + 1) = IWRK
10943 : End Do
10944 : Return
10945 : !
10946 : !
10947 0 : End Subroutine I_rnkpar
10948 :
10949 0 : Subroutine D_uniinv (XDONT, IGOEST)
10950 : ! __________________________________________________________
10951 : ! UNIINV = Merge-sort inverse ranking of an array, with removal of
10952 : ! duplicate entries.
10953 : ! The routine is similar to pure merge-sort ranking, but on
10954 : ! the last pass, it sets indices in IGOEST to the rank
10955 : ! of the value in the ordered set with duplicates removed.
10956 : ! For performance reasons, the first 2 passes are taken
10957 : ! out of the standard loop, and use dedicated coding.
10958 : ! __________________________________________________________
10959 : ! __________________________________________________________
10960 : real(kind = dp), Dimension (:), Intent (In) :: XDONT
10961 : Integer(kind = i4), Dimension (:), Intent (Out) :: IGOEST
10962 : ! __________________________________________________________
10963 0 : real(kind = dp) :: XTST, XDONA, XDONB
10964 : !
10965 : ! __________________________________________________________
10966 0 : Integer(kind = i4), Dimension (SIZE(IGOEST)) :: JWRKT, IRNGT
10967 : Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2, NUNI
10968 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
10969 : !
10970 0 : NVAL = Min (SIZE(XDONT), SIZE(IGOEST))
10971 : !
10972 : Select Case (NVAL)
10973 : Case (: 0)
10974 0 : Return
10975 : Case (1)
10976 0 : IGOEST (1) = 1
10977 0 : Return
10978 : Case Default
10979 :
10980 : End Select
10981 : !
10982 : ! Fill-in the index array, creating ordered couples
10983 : !
10984 0 : Do IIND = 2, NVAL, 2
10985 0 : If (XDONT(IIND - 1) < XDONT(IIND)) Then
10986 0 : IRNGT (IIND - 1) = IIND - 1
10987 0 : IRNGT (IIND) = IIND
10988 : Else
10989 0 : IRNGT (IIND - 1) = IIND
10990 0 : IRNGT (IIND) = IIND - 1
10991 : End If
10992 : End Do
10993 0 : If (Modulo (NVAL, 2) /= 0) Then
10994 0 : IRNGT (NVAL) = NVAL
10995 : End If
10996 : !
10997 : ! We will now have ordered subsets A - B - A - B - ...
10998 : ! and merge A and B couples into C - C - ...
10999 : !
11000 0 : LMTNA = 2
11001 0 : LMTNC = 4
11002 : !
11003 : ! First iteration. The length of the ordered subsets goes from 2 to 4
11004 : !
11005 : Do
11006 0 : If (NVAL <= 4) Exit
11007 : !
11008 : ! Loop on merges of A and B into C
11009 : !
11010 0 : Do IWRKD = 0, NVAL - 1, 4
11011 0 : If ((IWRKD + 4) > NVAL) Then
11012 0 : If ((IWRKD + 2) >= NVAL) Exit
11013 : !
11014 : ! 1 2 3
11015 : !
11016 0 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Exit
11017 : !
11018 : ! 1 3 2
11019 : !
11020 0 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
11021 0 : IRNG2 = IRNGT (IWRKD + 2)
11022 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
11023 0 : IRNGT (IWRKD + 3) = IRNG2
11024 : !
11025 : ! 3 1 2
11026 : !
11027 : Else
11028 0 : IRNG1 = IRNGT (IWRKD + 1)
11029 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
11030 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 2)
11031 0 : IRNGT (IWRKD + 2) = IRNG1
11032 : End If
11033 : If (.true.) Exit ! Exit ! JM
11034 : End If
11035 : !
11036 : ! 1 2 3 4
11037 : !
11038 0 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Cycle
11039 : !
11040 : ! 1 3 x x
11041 : !
11042 0 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
11043 0 : IRNG2 = IRNGT (IWRKD + 2)
11044 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
11045 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
11046 : ! 1 3 2 4
11047 0 : IRNGT (IWRKD + 3) = IRNG2
11048 : Else
11049 : ! 1 3 4 2
11050 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
11051 0 : IRNGT (IWRKD + 4) = IRNG2
11052 : End If
11053 : !
11054 : ! 3 x x x
11055 : !
11056 : Else
11057 0 : IRNG1 = IRNGT (IWRKD + 1)
11058 0 : IRNG2 = IRNGT (IWRKD + 2)
11059 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
11060 0 : If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD + 4))) Then
11061 0 : IRNGT (IWRKD + 2) = IRNG1
11062 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
11063 : ! 3 1 2 4
11064 0 : IRNGT (IWRKD + 3) = IRNG2
11065 : Else
11066 : ! 3 1 4 2
11067 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
11068 0 : IRNGT (IWRKD + 4) = IRNG2
11069 : End If
11070 : Else
11071 : ! 3 4 1 2
11072 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 4)
11073 0 : IRNGT (IWRKD + 3) = IRNG1
11074 0 : IRNGT (IWRKD + 4) = IRNG2
11075 : End If
11076 : End If
11077 : End Do
11078 : !
11079 : ! The Cs become As and Bs
11080 : !
11081 : LMTNA = 4
11082 0 : If (.true.) Exit ! Exit ! JM
11083 : End Do
11084 : !
11085 : ! Iteration loop. Each time, the length of the ordered subsets
11086 : ! is doubled.
11087 : !
11088 : Do
11089 0 : If (2 * LMTNA >= NVAL) Exit
11090 0 : IWRKF = 0
11091 0 : LMTNC = 2 * LMTNC
11092 : !
11093 : ! Loop on merges of A and B into C
11094 : !
11095 : Do
11096 0 : IWRK = IWRKF
11097 0 : IWRKD = IWRKF + 1
11098 0 : JINDA = IWRKF + LMTNA
11099 0 : IWRKF = IWRKF + LMTNC
11100 0 : If (IWRKF >= NVAL) Then
11101 0 : If (JINDA >= NVAL) Exit
11102 : IWRKF = NVAL
11103 : End If
11104 0 : IINDA = 1
11105 0 : IINDB = JINDA + 1
11106 : !
11107 : ! One steps in the C subset, that we create in the final rank array
11108 : !
11109 : ! Make a copy of the rank array for the iteration
11110 : !
11111 0 : JWRKT (1 : LMTNA) = IRNGT (IWRKD : JINDA)
11112 0 : XDONA = XDONT (JWRKT(IINDA))
11113 0 : XDONB = XDONT (IRNGT(IINDB))
11114 : !
11115 0 : Do
11116 0 : IWRK = IWRK + 1
11117 : !
11118 : ! We still have unprocessed values in both A and B
11119 : !
11120 0 : If (XDONA > XDONB) Then
11121 0 : IRNGT (IWRK) = IRNGT (IINDB)
11122 0 : IINDB = IINDB + 1
11123 0 : If (IINDB > IWRKF) Then
11124 : ! Only A still with unprocessed values
11125 0 : IRNGT (IWRK + 1 : IWRKF) = JWRKT (IINDA : LMTNA)
11126 : Exit
11127 : End If
11128 0 : XDONB = XDONT (IRNGT(IINDB))
11129 : Else
11130 0 : IRNGT (IWRK) = JWRKT (IINDA)
11131 0 : IINDA = IINDA + 1
11132 0 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
11133 0 : XDONA = XDONT (JWRKT(IINDA))
11134 : End If
11135 : !
11136 : End Do
11137 : End Do
11138 : !
11139 : ! The Cs become As and Bs
11140 : !
11141 0 : LMTNA = 2 * LMTNA
11142 : End Do
11143 : !
11144 : ! Last merge of A and B into C, with removal of duplicates.
11145 : !
11146 0 : IINDA = 1
11147 0 : IINDB = LMTNA + 1
11148 0 : NUNI = 0
11149 : !
11150 : ! One steps in the C subset, that we create in the final rank array
11151 : !
11152 0 : JWRKT (1 : LMTNA) = IRNGT (1 : LMTNA)
11153 0 : If (IINDB <= NVAL) Then
11154 0 : XTST = NEARLESS (Min(XDONT(JWRKT(1)), XDONT(IRNGT(IINDB))))
11155 : Else
11156 0 : XTST = NEARLESS (XDONT(JWRKT(1)))
11157 : end if
11158 0 : Do IWRK = 1, NVAL
11159 : !
11160 : ! We still have unprocessed values in both A and B
11161 : !
11162 0 : If (IINDA <= LMTNA) Then
11163 0 : If (IINDB <= NVAL) Then
11164 0 : If (XDONT(JWRKT(IINDA)) > XDONT(IRNGT(IINDB))) Then
11165 0 : IRNG = IRNGT (IINDB)
11166 0 : IINDB = IINDB + 1
11167 : Else
11168 0 : IRNG = JWRKT (IINDA)
11169 0 : IINDA = IINDA + 1
11170 : End If
11171 : Else
11172 : !
11173 : ! Only A still with unprocessed values
11174 : !
11175 0 : IRNG = JWRKT (IINDA)
11176 0 : IINDA = IINDA + 1
11177 : End If
11178 : Else
11179 : !
11180 : ! Only B still with unprocessed values
11181 : !
11182 0 : IRNG = IRNGT (IWRK)
11183 : End If
11184 0 : If (XDONT(IRNG) > XTST) Then
11185 0 : XTST = XDONT (IRNG)
11186 0 : NUNI = NUNI + 1
11187 : End If
11188 0 : IGOEST (IRNG) = NUNI
11189 : !
11190 : End Do
11191 : !
11192 : Return
11193 : !
11194 0 : End Subroutine D_uniinv
11195 :
11196 0 : Subroutine R_uniinv (XDONT, IGOEST)
11197 : ! __________________________________________________________
11198 : ! UNIINV = Merge-sort inverse ranking of an array, with removal of
11199 : ! duplicate entries.
11200 : ! The routine is similar to pure merge-sort ranking, but on
11201 : ! the last pass, it sets indices in IGOEST to the rank
11202 : ! of the value in the ordered set with duplicates removed.
11203 : ! For performance reasons, the first 2 passes are taken
11204 : ! out of the standard loop, and use dedicated coding.
11205 : ! __________________________________________________________
11206 : ! _________________________________________________________
11207 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
11208 : Integer(kind = i4), Dimension (:), Intent (Out) :: IGOEST
11209 : ! __________________________________________________________
11210 0 : Real(kind = sp) :: XTST, XDONA, XDONB
11211 : !
11212 : ! __________________________________________________________
11213 0 : Integer(kind = i4), Dimension (SIZE(IGOEST)) :: JWRKT, IRNGT
11214 : Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2, NUNI
11215 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
11216 : !
11217 0 : NVAL = Min (SIZE(XDONT), SIZE(IGOEST))
11218 : !
11219 : Select Case (NVAL)
11220 : Case (: 0)
11221 0 : Return
11222 : Case (1)
11223 0 : IGOEST (1) = 1
11224 0 : Return
11225 : Case Default
11226 :
11227 : End Select
11228 : !
11229 : ! Fill-in the index array, creating ordered couples
11230 : !
11231 0 : Do IIND = 2, NVAL, 2
11232 0 : If (XDONT(IIND - 1) < XDONT(IIND)) Then
11233 0 : IRNGT (IIND - 1) = IIND - 1
11234 0 : IRNGT (IIND) = IIND
11235 : Else
11236 0 : IRNGT (IIND - 1) = IIND
11237 0 : IRNGT (IIND) = IIND - 1
11238 : End If
11239 : End Do
11240 0 : If (Modulo (NVAL, 2) /= 0) Then
11241 0 : IRNGT (NVAL) = NVAL
11242 : End If
11243 : !
11244 : ! We will now have ordered subsets A - B - A - B - ...
11245 : ! and merge A and B couples into C - C - ...
11246 : !
11247 0 : LMTNA = 2
11248 0 : LMTNC = 4
11249 : !
11250 : ! First iteration. The length of the ordered subsets goes from 2 to 4
11251 : !
11252 : Do
11253 0 : If (NVAL <= 4) Exit
11254 : !
11255 : ! Loop on merges of A and B into C
11256 : !
11257 0 : Do IWRKD = 0, NVAL - 1, 4
11258 0 : If ((IWRKD + 4) > NVAL) Then
11259 0 : If ((IWRKD + 2) >= NVAL) Exit
11260 : !
11261 : ! 1 2 3
11262 : !
11263 0 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Exit
11264 : !
11265 : ! 1 3 2
11266 : !
11267 0 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
11268 0 : IRNG2 = IRNGT (IWRKD + 2)
11269 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
11270 0 : IRNGT (IWRKD + 3) = IRNG2
11271 : !
11272 : ! 3 1 2
11273 : !
11274 : Else
11275 0 : IRNG1 = IRNGT (IWRKD + 1)
11276 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
11277 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 2)
11278 0 : IRNGT (IWRKD + 2) = IRNG1
11279 : End If
11280 : If (.true.) Exit ! Exit ! JM
11281 : End If
11282 : !
11283 : ! 1 2 3 4
11284 : !
11285 0 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Cycle
11286 : !
11287 : ! 1 3 x x
11288 : !
11289 0 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
11290 0 : IRNG2 = IRNGT (IWRKD + 2)
11291 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
11292 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
11293 : ! 1 3 2 4
11294 0 : IRNGT (IWRKD + 3) = IRNG2
11295 : Else
11296 : ! 1 3 4 2
11297 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
11298 0 : IRNGT (IWRKD + 4) = IRNG2
11299 : End If
11300 : !
11301 : ! 3 x x x
11302 : !
11303 : Else
11304 0 : IRNG1 = IRNGT (IWRKD + 1)
11305 0 : IRNG2 = IRNGT (IWRKD + 2)
11306 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
11307 0 : If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD + 4))) Then
11308 0 : IRNGT (IWRKD + 2) = IRNG1
11309 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
11310 : ! 3 1 2 4
11311 0 : IRNGT (IWRKD + 3) = IRNG2
11312 : Else
11313 : ! 3 1 4 2
11314 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
11315 0 : IRNGT (IWRKD + 4) = IRNG2
11316 : End If
11317 : Else
11318 : ! 3 4 1 2
11319 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 4)
11320 0 : IRNGT (IWRKD + 3) = IRNG1
11321 0 : IRNGT (IWRKD + 4) = IRNG2
11322 : End If
11323 : End If
11324 : End Do
11325 : !
11326 : ! The Cs become As and Bs
11327 : !
11328 : LMTNA = 4
11329 0 : If (.true.) Exit ! Exit ! JM
11330 : End Do
11331 : !
11332 : ! Iteration loop. Each time, the length of the ordered subsets
11333 : ! is doubled.
11334 : !
11335 : Do
11336 0 : If (2 * LMTNA >= NVAL) Exit
11337 0 : IWRKF = 0
11338 0 : LMTNC = 2 * LMTNC
11339 : !
11340 : ! Loop on merges of A and B into C
11341 : !
11342 : Do
11343 0 : IWRK = IWRKF
11344 0 : IWRKD = IWRKF + 1
11345 0 : JINDA = IWRKF + LMTNA
11346 0 : IWRKF = IWRKF + LMTNC
11347 0 : If (IWRKF >= NVAL) Then
11348 0 : If (JINDA >= NVAL) Exit
11349 : IWRKF = NVAL
11350 : End If
11351 0 : IINDA = 1
11352 0 : IINDB = JINDA + 1
11353 : !
11354 : ! One steps in the C subset, that we create in the final rank array
11355 : !
11356 : ! Make a copy of the rank array for the iteration
11357 : !
11358 0 : JWRKT (1 : LMTNA) = IRNGT (IWRKD : JINDA)
11359 0 : XDONA = XDONT (JWRKT(IINDA))
11360 0 : XDONB = XDONT (IRNGT(IINDB))
11361 : !
11362 0 : Do
11363 0 : IWRK = IWRK + 1
11364 : !
11365 : ! We still have unprocessed values in both A and B
11366 : !
11367 0 : If (XDONA > XDONB) Then
11368 0 : IRNGT (IWRK) = IRNGT (IINDB)
11369 0 : IINDB = IINDB + 1
11370 0 : If (IINDB > IWRKF) Then
11371 : ! Only A still with unprocessed values
11372 0 : IRNGT (IWRK + 1 : IWRKF) = JWRKT (IINDA : LMTNA)
11373 : Exit
11374 : End If
11375 0 : XDONB = XDONT (IRNGT(IINDB))
11376 : Else
11377 0 : IRNGT (IWRK) = JWRKT (IINDA)
11378 0 : IINDA = IINDA + 1
11379 0 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
11380 0 : XDONA = XDONT (JWRKT(IINDA))
11381 : End If
11382 : !
11383 : End Do
11384 : End Do
11385 : !
11386 : ! The Cs become As and Bs
11387 : !
11388 0 : LMTNA = 2 * LMTNA
11389 : End Do
11390 : !
11391 : ! Last merge of A and B into C, with removal of duplicates.
11392 : !
11393 0 : IINDA = 1
11394 0 : IINDB = LMTNA + 1
11395 0 : NUNI = 0
11396 : !
11397 : ! One steps in the C subset, that we create in the final rank array
11398 : !
11399 0 : JWRKT (1 : LMTNA) = IRNGT (1 : LMTNA)
11400 0 : If (IINDB <= NVAL) Then
11401 0 : XTST = NEARLESS (Min(XDONT(JWRKT(1)), XDONT(IRNGT(IINDB))))
11402 : Else
11403 0 : XTST = NEARLESS (XDONT(JWRKT(1)))
11404 : end if
11405 0 : Do IWRK = 1, NVAL
11406 : !
11407 : ! We still have unprocessed values in both A and B
11408 : !
11409 0 : If (IINDA <= LMTNA) Then
11410 0 : If (IINDB <= NVAL) Then
11411 0 : If (XDONT(JWRKT(IINDA)) > XDONT(IRNGT(IINDB))) Then
11412 0 : IRNG = IRNGT (IINDB)
11413 0 : IINDB = IINDB + 1
11414 : Else
11415 0 : IRNG = JWRKT (IINDA)
11416 0 : IINDA = IINDA + 1
11417 : End If
11418 : Else
11419 : !
11420 : ! Only A still with unprocessed values
11421 : !
11422 0 : IRNG = JWRKT (IINDA)
11423 0 : IINDA = IINDA + 1
11424 : End If
11425 : Else
11426 : !
11427 : ! Only B still with unprocessed values
11428 : !
11429 0 : IRNG = IRNGT (IWRK)
11430 : End If
11431 0 : If (XDONT(IRNG) > XTST) Then
11432 0 : XTST = XDONT (IRNG)
11433 0 : NUNI = NUNI + 1
11434 : End If
11435 0 : IGOEST (IRNG) = NUNI
11436 : !
11437 : End Do
11438 : !
11439 : Return
11440 : !
11441 0 : End Subroutine R_uniinv
11442 :
11443 8 : Subroutine I_uniinv (XDONT, IGOEST)
11444 : ! __________________________________________________________
11445 : ! UNIINV = Merge-sort inverse ranking of an array, with removal of
11446 : ! duplicate entries.
11447 : ! The routine is similar to pure merge-sort ranking, but on
11448 : ! the last pass, it sets indices in IGOEST to the rank
11449 : ! of the value in the ordered set with duplicates removed.
11450 : ! For performance reasons, the first 2 passes are taken
11451 : ! out of the standard loop, and use dedicated coding.
11452 : ! __________________________________________________________
11453 : ! __________________________________________________________
11454 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
11455 : Integer(kind = i4), Dimension (:), Intent (Out) :: IGOEST
11456 : ! __________________________________________________________
11457 : Integer(kind = i4) :: XTST, XDONA, XDONB
11458 : !
11459 : ! __________________________________________________________
11460 4 : Integer(kind = i4), Dimension (SIZE(IGOEST)) :: JWRKT, IRNGT
11461 : Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2, NUNI
11462 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
11463 : !
11464 4 : NVAL = Min (SIZE(XDONT), SIZE(IGOEST))
11465 : !
11466 : Select Case (NVAL)
11467 : Case (: 0)
11468 0 : Return
11469 : Case (1)
11470 0 : IGOEST (1) = 1
11471 4 : Return
11472 : Case Default
11473 :
11474 : End Select
11475 : !
11476 : ! Fill-in the index array, creating ordered couples
11477 : !
11478 20 : Do IIND = 2, NVAL, 2
11479 20 : If (XDONT(IIND - 1) < XDONT(IIND)) Then
11480 4 : IRNGT (IIND - 1) = IIND - 1
11481 4 : IRNGT (IIND) = IIND
11482 : Else
11483 12 : IRNGT (IIND - 1) = IIND
11484 12 : IRNGT (IIND) = IIND - 1
11485 : End If
11486 : End Do
11487 4 : If (Modulo (NVAL, 2) /= 0) Then
11488 4 : IRNGT (NVAL) = NVAL
11489 : End If
11490 : !
11491 : ! We will now have ordered subsets A - B - A - B - ...
11492 : ! and merge A and B couples into C - C - ...
11493 : !
11494 4 : LMTNA = 2
11495 4 : LMTNC = 4
11496 : !
11497 : ! First iteration. The length of the ordered subsets goes from 2 to 4
11498 : !
11499 : Do
11500 4 : If (NVAL <= 4) Exit
11501 : !
11502 : ! Loop on merges of A and B into C
11503 : !
11504 12 : Do IWRKD = 0, NVAL - 1, 4
11505 12 : If ((IWRKD + 4) > NVAL) Then
11506 4 : If ((IWRKD + 2) >= NVAL) Exit
11507 : !
11508 : ! 1 2 3
11509 : !
11510 0 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Exit
11511 : !
11512 : ! 1 3 2
11513 : !
11514 0 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
11515 0 : IRNG2 = IRNGT (IWRKD + 2)
11516 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
11517 0 : IRNGT (IWRKD + 3) = IRNG2
11518 : !
11519 : ! 3 1 2
11520 : !
11521 : Else
11522 0 : IRNG1 = IRNGT (IWRKD + 1)
11523 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
11524 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 2)
11525 0 : IRNGT (IWRKD + 2) = IRNG1
11526 : End If
11527 : If (.true.) Exit ! Exit ! JM
11528 : End If
11529 : !
11530 : ! 1 2 3 4
11531 : !
11532 8 : If (XDONT(IRNGT(IWRKD + 2)) <= XDONT(IRNGT(IWRKD + 3))) Cycle
11533 : !
11534 : ! 1 3 x x
11535 : !
11536 12 : If (XDONT(IRNGT(IWRKD + 1)) <= XDONT(IRNGT(IWRKD + 3))) Then
11537 4 : IRNG2 = IRNGT (IWRKD + 2)
11538 4 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
11539 4 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
11540 : ! 1 3 2 4
11541 4 : IRNGT (IWRKD + 3) = IRNG2
11542 : Else
11543 : ! 1 3 4 2
11544 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
11545 0 : IRNGT (IWRKD + 4) = IRNG2
11546 : End If
11547 : !
11548 : ! 3 x x x
11549 : !
11550 : Else
11551 4 : IRNG1 = IRNGT (IWRKD + 1)
11552 4 : IRNG2 = IRNGT (IWRKD + 2)
11553 4 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
11554 4 : If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD + 4))) Then
11555 0 : IRNGT (IWRKD + 2) = IRNG1
11556 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD + 4))) Then
11557 : ! 3 1 2 4
11558 0 : IRNGT (IWRKD + 3) = IRNG2
11559 : Else
11560 : ! 3 1 4 2
11561 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
11562 0 : IRNGT (IWRKD + 4) = IRNG2
11563 : End If
11564 : Else
11565 : ! 3 4 1 2
11566 4 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 4)
11567 4 : IRNGT (IWRKD + 3) = IRNG1
11568 4 : IRNGT (IWRKD + 4) = IRNG2
11569 : End If
11570 : End If
11571 : End Do
11572 : !
11573 : ! The Cs become As and Bs
11574 : !
11575 : LMTNA = 4
11576 0 : If (.true.) Exit ! Exit ! JM
11577 : End Do
11578 : !
11579 : ! Iteration loop. Each time, the length of the ordered subsets
11580 : ! is doubled.
11581 : !
11582 : Do
11583 8 : If (2 * LMTNA >= NVAL) Exit
11584 4 : IWRKF = 0
11585 4 : LMTNC = 2 * LMTNC
11586 : !
11587 : ! Loop on merges of A and B into C
11588 : !
11589 : Do
11590 8 : IWRK = IWRKF
11591 8 : IWRKD = IWRKF + 1
11592 8 : JINDA = IWRKF + LMTNA
11593 8 : IWRKF = IWRKF + LMTNC
11594 8 : If (IWRKF >= NVAL) Then
11595 4 : If (JINDA >= NVAL) Exit
11596 : IWRKF = NVAL
11597 : End If
11598 4 : IINDA = 1
11599 4 : IINDB = JINDA + 1
11600 : !
11601 : ! One steps in the C subset, that we create in the final rank array
11602 : !
11603 : ! Make a copy of the rank array for the iteration
11604 : !
11605 20 : JWRKT (1 : LMTNA) = IRNGT (IWRKD : JINDA)
11606 4 : XDONA = XDONT (JWRKT(IINDA))
11607 4 : XDONB = XDONT (IRNGT(IINDB))
11608 : !
11609 4 : Do
11610 28 : IWRK = IWRK + 1
11611 : !
11612 : ! We still have unprocessed values in both A and B
11613 : !
11614 32 : If (XDONA > XDONB) Then
11615 12 : IRNGT (IWRK) = IRNGT (IINDB)
11616 12 : IINDB = IINDB + 1
11617 12 : If (IINDB > IWRKF) Then
11618 : ! Only A still with unprocessed values
11619 0 : IRNGT (IWRK + 1 : IWRKF) = JWRKT (IINDA : LMTNA)
11620 : Exit
11621 : End If
11622 12 : XDONB = XDONT (IRNGT(IINDB))
11623 : Else
11624 16 : IRNGT (IWRK) = JWRKT (IINDA)
11625 16 : IINDA = IINDA + 1
11626 16 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
11627 12 : XDONA = XDONT (JWRKT(IINDA))
11628 : End If
11629 : !
11630 : End Do
11631 : End Do
11632 : !
11633 : ! The Cs become As and Bs
11634 : !
11635 4 : LMTNA = 2 * LMTNA
11636 : End Do
11637 : !
11638 : ! Last merge of A and B into C, with removal of duplicates.
11639 : !
11640 4 : IINDA = 1
11641 4 : IINDB = LMTNA + 1
11642 4 : NUNI = 0
11643 : !
11644 : ! One steps in the C subset, that we create in the final rank array
11645 : !
11646 36 : JWRKT (1 : LMTNA) = IRNGT (1 : LMTNA)
11647 4 : If (IINDB <= NVAL) Then
11648 4 : XTST = NEARLESS (Min(XDONT(JWRKT(1)), XDONT(IRNGT(IINDB))))
11649 : Else
11650 0 : XTST = NEARLESS (XDONT(JWRKT(1)))
11651 : end if
11652 40 : Do IWRK = 1, NVAL
11653 : !
11654 : ! We still have unprocessed values in both A and B
11655 : !
11656 36 : If (IINDA <= LMTNA) Then
11657 32 : If (IINDB <= NVAL) Then
11658 32 : If (XDONT(JWRKT(IINDA)) > XDONT(IRNGT(IINDB))) Then
11659 0 : IRNG = IRNGT (IINDB)
11660 0 : IINDB = IINDB + 1
11661 : Else
11662 32 : IRNG = JWRKT (IINDA)
11663 32 : IINDA = IINDA + 1
11664 : End If
11665 : Else
11666 : !
11667 : ! Only A still with unprocessed values
11668 : !
11669 0 : IRNG = JWRKT (IINDA)
11670 0 : IINDA = IINDA + 1
11671 : End If
11672 : Else
11673 : !
11674 : ! Only B still with unprocessed values
11675 : !
11676 4 : IRNG = IRNGT (IWRK)
11677 : End If
11678 36 : If (XDONT(IRNG) > XTST) Then
11679 12 : XTST = XDONT (IRNG)
11680 12 : NUNI = NUNI + 1
11681 : End If
11682 40 : IGOEST (IRNG) = NUNI
11683 : !
11684 : End Do
11685 : !
11686 : Return
11687 : !
11688 0 : End Subroutine I_uniinv
11689 :
11690 0 : Function D_nearless (XVAL) result (D_nl)
11691 : ! Nearest value less than given value
11692 : ! __________________________________________________________
11693 : real(kind = dp), Intent (In) :: XVAL
11694 : real(kind = dp) :: D_nl
11695 : ! __________________________________________________________
11696 0 : D_nl = nearest (XVAL, -1.0_dp)
11697 : return
11698 : !
11699 4 : End Function D_nearless
11700 :
11701 0 : Function R_nearless (XVAL) result (R_nl)
11702 : ! Nearest value less than given value
11703 : ! __________________________________________________________
11704 : Real(kind = sp), Intent (In) :: XVAL
11705 : Real(kind = sp) :: R_nl
11706 : ! __________________________________________________________
11707 0 : R_nl = nearest (XVAL, -1.0)
11708 : return
11709 : !
11710 0 : End Function R_nearless
11711 :
11712 4 : Function I_nearless (XVAL) result (I_nl)
11713 : ! Nearest value less than given value
11714 : ! __________________________________________________________
11715 : Integer(kind = i4), Intent (In) :: XVAL
11716 : Integer(kind = i4) :: I_nl
11717 : ! __________________________________________________________
11718 4 : I_nl = XVAL - 1
11719 : return
11720 : !
11721 4 : End Function I_nearless
11722 :
11723 :
11724 0 : Subroutine D_unipar (XDONT, IRNGT, NORD)
11725 : ! Ranks partially XDONT by IRNGT, up to order NORD at most,
11726 : ! removing duplicate entries
11727 : ! __________________________________________________________
11728 : ! This routine uses a pivoting strategy such as the one of
11729 : ! finding the median based on the quicksort algorithm, but
11730 : ! we skew the pivot choice to try to bring it to NORD as
11731 : ! quickly as possible. It uses 2 temporary arrays, where it
11732 : ! stores the indices of the values smaller than the pivot
11733 : ! (ILOWT), and the indices of values larger than the pivot
11734 : ! that we might still need later on (IHIGT). It iterates
11735 : ! until it can bring the number of values in ILOWT to
11736 : ! exactly NORD, and then uses an insertion sort to rank
11737 : ! this set, since it is supposedly small. At all times, the
11738 : ! NORD first values in ILOWT correspond to distinct values
11739 : ! of the input array.
11740 : ! Michel Olagnon - Feb. 2000
11741 : ! __________________________________________________________
11742 : ! __________________________________________________________
11743 : real(kind = dp), Dimension (:), Intent (In) :: XDONT
11744 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
11745 : Integer(kind = i4), Intent (InOut) :: NORD
11746 : ! __________________________________________________________
11747 0 : real(kind = dp) :: XPIV, XWRK, XWRK1, XMIN, XMAX, XPIV0
11748 : !
11749 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
11750 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
11751 : Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
11752 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
11753 : !
11754 0 : NDON = SIZE (XDONT)
11755 : !
11756 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
11757 : !
11758 0 : If (NDON < 2) Then
11759 0 : If (NORD >= 1) Then
11760 0 : NORD = 1
11761 0 : IRNGT (1) = 1
11762 : End If
11763 0 : Return
11764 : End If
11765 : !
11766 : ! One chooses a pivot, best estimate possible to put fractile near
11767 : ! mid-point of the set of low values.
11768 : !
11769 0 : Do ICRS = 2, NDON
11770 0 : If (eq(XDONT(ICRS), XDONT(1))) Then
11771 : Cycle
11772 0 : Else If (XDONT(ICRS) < XDONT(1)) Then
11773 0 : ILOWT (1) = ICRS
11774 0 : IHIGT (1) = 1
11775 : Else
11776 0 : ILOWT (1) = 1
11777 0 : IHIGT (1) = ICRS
11778 : End If
11779 0 : If (.true.) Exit ! Exit ! JM
11780 : End Do
11781 : !
11782 0 : If (NDON <= ICRS) Then
11783 0 : NORD = Min (NORD, 2)
11784 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
11785 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
11786 0 : Return
11787 : End If
11788 : !
11789 0 : ICRS = ICRS + 1
11790 0 : JHIG = 1
11791 0 : If (XDONT(ICRS) < XDONT(IHIGT(1))) Then
11792 0 : If (XDONT(ICRS) < XDONT(ILOWT(1))) Then
11793 0 : JHIG = JHIG + 1
11794 0 : IHIGT (JHIG) = IHIGT (1)
11795 0 : IHIGT (1) = ILOWT (1)
11796 0 : ILOWT (1) = ICRS
11797 0 : Else If (XDONT(ICRS) > XDONT(ILOWT(1))) Then
11798 0 : JHIG = JHIG + 1
11799 0 : IHIGT (JHIG) = IHIGT (1)
11800 0 : IHIGT (1) = ICRS
11801 : End If
11802 0 : ElseIf (XDONT(ICRS) > XDONT(IHIGT(1))) Then
11803 0 : JHIG = JHIG + 1
11804 0 : IHIGT (JHIG) = ICRS
11805 : End If
11806 : !
11807 0 : If (NDON <= ICRS) Then
11808 0 : NORD = Min (NORD, JHIG + 1)
11809 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
11810 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
11811 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
11812 0 : Return
11813 : End If
11814 : !
11815 0 : If (XDONT(NDON) < XDONT(IHIGT(1))) Then
11816 0 : If (XDONT(NDON) < XDONT(ILOWT(1))) Then
11817 0 : Do IDCR = JHIG, 1, -1
11818 0 : IHIGT (IDCR + 1) = IHIGT (IDCR)
11819 : End Do
11820 0 : IHIGT (1) = ILOWT (1)
11821 0 : ILOWT (1) = NDON
11822 0 : JHIG = JHIG + 1
11823 0 : ElseIf (XDONT(NDON) > XDONT(ILOWT(1))) Then
11824 0 : Do IDCR = JHIG, 1, -1
11825 0 : IHIGT (IDCR + 1) = IHIGT (IDCR)
11826 : End Do
11827 0 : IHIGT (1) = NDON
11828 0 : JHIG = JHIG + 1
11829 : End If
11830 0 : ElseIf (XDONT(NDON) > XDONT(IHIGT(1))) Then
11831 0 : JHIG = JHIG + 1
11832 0 : IHIGT (JHIG) = NDON
11833 : End If
11834 : !
11835 0 : If (NDON <= ICRS + 1) Then
11836 0 : NORD = Min (NORD, JHIG + 1)
11837 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
11838 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
11839 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
11840 0 : If (NORD >= 4) IRNGT (4) = IHIGT (3)
11841 0 : Return
11842 : End If
11843 : !
11844 0 : JDEB = 0
11845 0 : IDEB = JDEB + 1
11846 0 : JLOW = IDEB
11847 0 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, dp) / REAL(NDON + NORD, dp) * &
11848 0 : (XDONT(IHIGT(3)) - XDONT(ILOWT(IDEB)))
11849 0 : If (XPIV >= XDONT(IHIGT(1))) Then
11850 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, dp) / REAL(NDON + NORD, dp) * &
11851 0 : (XDONT(IHIGT(2)) - XDONT(ILOWT(IDEB)))
11852 0 : If (XPIV >= XDONT(IHIGT(1))) &
11853 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, dp) / REAL(NDON + NORD, dp) * &
11854 0 : (XDONT(IHIGT(1)) - XDONT(ILOWT(IDEB)))
11855 : End If
11856 0 : XPIV0 = XPIV
11857 : !
11858 : ! One puts values > pivot in the end and those <= pivot
11859 : ! at the beginning. This is split in 2 cases, so that
11860 : ! we can skip the loop test a number of times.
11861 : ! As we are also filling in the work arrays at the same time
11862 : ! we stop filling in the IHIGT array as soon as we have more
11863 : ! than enough values in ILOWT, i.e. one more than
11864 : ! strictly necessary so as to be able to come out of the
11865 : ! case where JLOWT would be NORD distinct values followed
11866 : ! by values that are exclusively duplicates of these.
11867 : !
11868 : !
11869 0 : If (XDONT(NDON) > XPIV) Then
11870 : lowloop1 : Do
11871 0 : ICRS = ICRS + 1
11872 0 : If (XDONT(ICRS) > XPIV) Then
11873 0 : If (ICRS >= NDON) Exit
11874 0 : JHIG = JHIG + 1
11875 0 : IHIGT (JHIG) = ICRS
11876 : Else
11877 0 : Do ILOW = 1, JLOW
11878 0 : If (eq(XDONT(ICRS), XDONT(ILOWT(ILOW)))) Cycle lowloop1
11879 : End Do
11880 0 : JLOW = JLOW + 1
11881 0 : ILOWT (JLOW) = ICRS
11882 0 : If (JLOW >= NORD) Exit
11883 : End If
11884 : End Do lowloop1
11885 : !
11886 : ! One restricts further processing because it is no use
11887 : ! to store more high values
11888 : !
11889 0 : If (ICRS < NDON - 1) Then
11890 : Do
11891 0 : ICRS = ICRS + 1
11892 0 : If (XDONT(ICRS) <= XPIV) Then
11893 0 : JLOW = JLOW + 1
11894 0 : ILOWT (JLOW) = ICRS
11895 0 : Else If (ICRS >= NDON) Then
11896 : Exit
11897 : End If
11898 : End Do
11899 : End If
11900 : !
11901 : !
11902 : Else
11903 : !
11904 : ! Same as above, but this is not as easy to optimize, so the
11905 : ! DO-loop is kept
11906 : !
11907 0 : lowloop2 : Do ICRS = ICRS + 1, NDON - 1
11908 0 : If (XDONT(ICRS) > XPIV) Then
11909 0 : JHIG = JHIG + 1
11910 0 : IHIGT (JHIG) = ICRS
11911 : Else
11912 0 : Do ILOW = 1, JLOW
11913 0 : If (eq(XDONT(ICRS), XDONT (ILOWT(ILOW)))) Cycle lowloop2
11914 : End Do
11915 0 : JLOW = JLOW + 1
11916 0 : ILOWT (JLOW) = ICRS
11917 0 : If (JLOW >= NORD) Exit
11918 : End If
11919 : End Do lowloop2
11920 : !
11921 0 : If (ICRS < NDON - 1) Then
11922 : Do
11923 0 : ICRS = ICRS + 1
11924 0 : If (XDONT(ICRS) <= XPIV) Then
11925 0 : If (ICRS >= NDON) Exit
11926 0 : JLOW = JLOW + 1
11927 0 : ILOWT (JLOW) = ICRS
11928 : End If
11929 : End Do
11930 : End If
11931 : End If
11932 : !
11933 : JLM2 = 0
11934 : JLM1 = 0
11935 : JHM2 = 0
11936 : JHM1 = 0
11937 : Do
11938 0 : if (JLOW == NORD) Exit
11939 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
11940 : !
11941 : ! We are oscillating. Perturbate by bringing JLOW closer by one
11942 : ! to NORD
11943 : !
11944 0 : If (NORD > JLOW) Then
11945 0 : XMIN = XDONT (IHIGT(1))
11946 0 : IHIG = 1
11947 0 : Do ICRS = 2, JHIG
11948 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
11949 0 : XMIN = XDONT (IHIGT(ICRS))
11950 0 : IHIG = ICRS
11951 : End If
11952 : End Do
11953 : !
11954 0 : JLOW = JLOW + 1
11955 0 : ILOWT (JLOW) = IHIGT (IHIG)
11956 0 : IHIG = 0
11957 0 : Do ICRS = 1, JHIG
11958 0 : If (ne(XDONT(IHIGT (ICRS)), XMIN)) then
11959 0 : IHIG = IHIG + 1
11960 0 : IHIGT (IHIG) = IHIGT (ICRS)
11961 : End If
11962 : End Do
11963 : JHIG = IHIG
11964 : Else
11965 0 : ILOW = ILOWT (JLOW)
11966 0 : XMAX = XDONT (ILOW)
11967 0 : Do ICRS = 1, JLOW
11968 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
11969 0 : IWRK = ILOWT (ICRS)
11970 0 : XMAX = XDONT (IWRK)
11971 0 : ILOWT (ICRS) = ILOW
11972 0 : ILOW = IWRK
11973 : End If
11974 : End Do
11975 0 : JLOW = JLOW - 1
11976 : End If
11977 : End If
11978 0 : JLM2 = JLM1
11979 0 : JLM1 = JLOW
11980 0 : JHM2 = JHM1
11981 0 : JHM1 = JHIG
11982 : !
11983 : ! We try to bring the number of values in the low values set
11984 : ! closer to NORD. In order to make better pivot choices, we
11985 : ! decrease NORD if we already know that we don't have that
11986 : ! many distinct values as a whole.
11987 : !
11988 0 : IF (JLOW + JHIG < NORD) NORD = JLOW + JHIG
11989 0 : Select Case (NORD - JLOW)
11990 : ! ______________________________
11991 : Case (2 :)
11992 : !
11993 : ! Not enough values in low part, at least 2 are missing
11994 : !
11995 0 : Select Case (JHIG)
11996 : !
11997 : ! Not enough values in high part either (too many duplicates)
11998 : !
11999 : Case (0)
12000 0 : NORD = JLOW
12001 : !
12002 : Case (1)
12003 0 : JLOW = JLOW + 1
12004 0 : ILOWT (JLOW) = IHIGT (1)
12005 0 : NORD = JLOW
12006 : !
12007 : ! We make a special case when we have so few values in
12008 : ! the high values set that it is bad performance to choose a pivot
12009 : ! and apply the general algorithm.
12010 : !
12011 : Case (2)
12012 0 : If (le(XDONT(IHIGT(1)), XDONT(IHIGT(2)))) Then
12013 0 : JLOW = JLOW + 1
12014 0 : ILOWT (JLOW) = IHIGT (1)
12015 0 : JLOW = JLOW + 1
12016 0 : ILOWT (JLOW) = IHIGT (2)
12017 0 : ElseIf (eq(XDONT(IHIGT(1)), XDONT(IHIGT(2)))) Then
12018 0 : JLOW = JLOW + 1
12019 0 : ILOWT (JLOW) = IHIGT (1)
12020 0 : NORD = JLOW
12021 : Else
12022 0 : JLOW = JLOW + 1
12023 0 : ILOWT (JLOW) = IHIGT (2)
12024 0 : JLOW = JLOW + 1
12025 0 : ILOWT (JLOW) = IHIGT (1)
12026 : End If
12027 : Exit
12028 : !
12029 : Case (3)
12030 : !
12031 : !
12032 0 : IWRK1 = IHIGT (1)
12033 0 : IWRK2 = IHIGT (2)
12034 0 : IWRK3 = IHIGT (3)
12035 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
12036 0 : IHIGT (1) = IWRK2
12037 0 : IHIGT (2) = IWRK1
12038 0 : IWRK2 = IWRK1
12039 : End If
12040 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
12041 0 : IHIGT (3) = IWRK2
12042 0 : IHIGT (2) = IWRK3
12043 0 : IWRK2 = IWRK3
12044 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
12045 0 : IHIGT (2) = IHIGT (1)
12046 0 : IHIGT (1) = IWRK2
12047 : End If
12048 : End If
12049 0 : JHIG = 1
12050 0 : JLOW = JLOW + 1
12051 0 : ILOWT (JLOW) = IHIGT (1)
12052 0 : JHIG = JHIG + 1
12053 0 : IF (ne(XDONT(IHIGT(JHIG)), XDONT(ILOWT(JLOW)))) Then
12054 0 : JLOW = JLOW + 1
12055 0 : ILOWT (JLOW) = IHIGT (JHIG)
12056 : End If
12057 0 : JHIG = JHIG + 1
12058 0 : IF (ne(XDONT(IHIGT(JHIG)), XDONT(ILOWT(JLOW)))) Then
12059 0 : JLOW = JLOW + 1
12060 0 : ILOWT (JLOW) = IHIGT (JHIG)
12061 : End If
12062 0 : NORD = Min (JLOW, NORD)
12063 0 : Exit
12064 : !
12065 : Case (4 :)
12066 : !
12067 : !
12068 0 : XPIV0 = XPIV
12069 0 : IFIN = JHIG
12070 : !
12071 : ! One chooses a pivot from the 2 first values and the last one.
12072 : ! This should ensure sufficient renewal between iterations to
12073 : ! avoid worst case behavior effects.
12074 : !
12075 0 : IWRK1 = IHIGT (1)
12076 0 : IWRK2 = IHIGT (2)
12077 0 : IWRK3 = IHIGT (IFIN)
12078 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
12079 0 : IHIGT (1) = IWRK2
12080 0 : IHIGT (2) = IWRK1
12081 0 : IWRK2 = IWRK1
12082 : End If
12083 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
12084 0 : IHIGT (IFIN) = IWRK2
12085 0 : IHIGT (2) = IWRK3
12086 0 : IWRK2 = IWRK3
12087 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
12088 0 : IHIGT (2) = IHIGT (1)
12089 0 : IHIGT (1) = IWRK2
12090 : End If
12091 : End If
12092 : !
12093 0 : JDEB = JLOW
12094 0 : NWRK = NORD - JLOW
12095 0 : IWRK1 = IHIGT (1)
12096 0 : XPIV = XDONT (IWRK1) + REAL(NWRK, dp) / REAL(NORD + NWRK, dp) * &
12097 0 : (XDONT(IHIGT(IFIN)) - XDONT(IWRK1))
12098 : !
12099 : ! One takes values <= pivot to ILOWT
12100 : ! Again, 2 parts, one where we take care of the remaining
12101 : ! high values because we might still need them, and the
12102 : ! other when we know that we will have more than enough
12103 : ! low values in the end.
12104 : !
12105 0 : JHIG = 0
12106 0 : lowloop3 : Do ICRS = 1, IFIN
12107 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
12108 0 : Do ILOW = 1, JLOW
12109 0 : If (eq(XDONT(IHIGT(ICRS)), XDONT (ILOWT(ILOW)))) &
12110 0 : Cycle lowloop3
12111 : End Do
12112 0 : JLOW = JLOW + 1
12113 0 : ILOWT (JLOW) = IHIGT (ICRS)
12114 0 : If (JLOW > NORD) Exit
12115 : Else
12116 0 : JHIG = JHIG + 1
12117 0 : IHIGT (JHIG) = IHIGT (ICRS)
12118 : End If
12119 : End Do lowloop3
12120 : !
12121 0 : Do ICRS = ICRS + 1, IFIN
12122 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
12123 0 : JLOW = JLOW + 1
12124 0 : ILOWT (JLOW) = IHIGT (ICRS)
12125 : End If
12126 : End Do
12127 : End Select
12128 : !
12129 : ! ______________________________
12130 : !
12131 : Case (1)
12132 : !
12133 : ! Only 1 value is missing in low part
12134 : !
12135 0 : XMIN = XDONT (IHIGT(1))
12136 0 : IHIG = 1
12137 0 : Do ICRS = 2, JHIG
12138 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
12139 0 : XMIN = XDONT (IHIGT(ICRS))
12140 0 : IHIG = ICRS
12141 : End If
12142 : End Do
12143 : !
12144 0 : JLOW = JLOW + 1
12145 0 : ILOWT (JLOW) = IHIGT (IHIG)
12146 0 : Exit
12147 : !
12148 : ! ______________________________
12149 : !
12150 : Case (0)
12151 : !
12152 : ! Low part is exactly what we want
12153 : !
12154 0 : Exit
12155 : !
12156 : ! ______________________________
12157 : !
12158 : Case (-5 : -1)
12159 : !
12160 : ! Only few values too many in low part
12161 : !
12162 0 : IRNGT (1) = ILOWT (1)
12163 0 : Do ICRS = 2, NORD
12164 0 : IWRK = ILOWT (ICRS)
12165 0 : XWRK = XDONT (IWRK)
12166 0 : Do IDCR = ICRS - 1, 1, - 1
12167 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
12168 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
12169 : Else
12170 : Exit
12171 : End If
12172 : End Do
12173 0 : IRNGT (IDCR + 1) = IWRK
12174 : End Do
12175 : !
12176 0 : XWRK1 = XDONT (IRNGT(NORD))
12177 0 : insert1 : Do ICRS = NORD + 1, JLOW
12178 0 : If (XDONT(ILOWT (ICRS)) < XWRK1) Then
12179 0 : XWRK = XDONT (ILOWT (ICRS))
12180 0 : Do ILOW = 1, NORD - 1
12181 0 : If (XWRK <= XDONT(IRNGT(ILOW))) Then
12182 0 : If (eq(XWRK, XDONT(IRNGT(ILOW)))) Cycle insert1
12183 : Exit
12184 : End If
12185 : End Do
12186 0 : Do IDCR = NORD - 1, ILOW, - 1
12187 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
12188 : End Do
12189 0 : IRNGT (IDCR + 1) = ILOWT (ICRS)
12190 0 : XWRK1 = XDONT (IRNGT(NORD))
12191 : End If
12192 : End Do insert1
12193 : !
12194 0 : Return
12195 : !
12196 : ! ______________________________
12197 : !
12198 : Case (: -6)
12199 : !
12200 : ! last case: too many values in low part
12201 : !
12202 0 : IDEB = JDEB + 1
12203 0 : IMIL = MIN ((JLOW + IDEB) / 2, NORD)
12204 0 : IFIN = MIN (JLOW, NORD + 1)
12205 : !
12206 : ! One chooses a pivot from 1st, last, and middle values
12207 : !
12208 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
12209 0 : IWRK = ILOWT (IDEB)
12210 0 : ILOWT (IDEB) = ILOWT (IMIL)
12211 0 : ILOWT (IMIL) = IWRK
12212 : End If
12213 0 : If (XDONT(ILOWT(IMIL)) > XDONT(ILOWT(IFIN))) Then
12214 0 : IWRK = ILOWT (IFIN)
12215 0 : ILOWT (IFIN) = ILOWT (IMIL)
12216 0 : ILOWT (IMIL) = IWRK
12217 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
12218 0 : IWRK = ILOWT (IDEB)
12219 0 : ILOWT (IDEB) = ILOWT (IMIL)
12220 0 : ILOWT (IMIL) = IWRK
12221 : End If
12222 : End If
12223 0 : If (IFIN <= 3) Exit
12224 : !
12225 0 : XPIV = XDONT (ILOWT(IDEB)) + REAL(NORD, dp) / REAL(JLOW + NORD, dp) * &
12226 0 : (XDONT(ILOWT(IFIN)) - XDONT(ILOWT(1)))
12227 0 : If (JDEB > 0) Then
12228 0 : If (XPIV <= XPIV0) &
12229 : XPIV = XPIV0 + REAL(2 * NORD - JDEB, dp) / REAL(JLOW + NORD, dp) * &
12230 0 : (XDONT(ILOWT(IFIN)) - XPIV0)
12231 : Else
12232 : IDEB = 1
12233 : End If
12234 : !
12235 : ! One takes values > XPIV to IHIGT
12236 : ! However, we do not process the first values if we have been
12237 : ! through the case when we did not have enough low values
12238 : !
12239 0 : JHIG = 0
12240 0 : IFIN = JLOW
12241 0 : JLOW = JDEB
12242 : !
12243 0 : If (XDONT(ILOWT(IFIN)) > XPIV) Then
12244 : ICRS = JDEB
12245 : lowloop4 : Do
12246 0 : ICRS = ICRS + 1
12247 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
12248 0 : JHIG = JHIG + 1
12249 0 : IHIGT (JHIG) = ILOWT (ICRS)
12250 0 : If (ICRS >= IFIN) Exit
12251 : Else
12252 0 : XWRK1 = XDONT(ILOWT(ICRS))
12253 0 : Do ILOW = IDEB, JLOW
12254 0 : If (eq(XWRK1, XDONT(ILOWT(ILOW)))) &
12255 0 : Cycle lowloop4
12256 : End Do
12257 0 : JLOW = JLOW + 1
12258 0 : ILOWT (JLOW) = ILOWT (ICRS)
12259 0 : If (JLOW >= NORD) Exit
12260 : End If
12261 : End Do lowloop4
12262 : !
12263 0 : If (ICRS < IFIN) Then
12264 : Do
12265 0 : ICRS = ICRS + 1
12266 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
12267 0 : JLOW = JLOW + 1
12268 0 : ILOWT (JLOW) = ILOWT (ICRS)
12269 : Else
12270 0 : If (ICRS >= IFIN) Exit
12271 : End If
12272 : End Do
12273 : End If
12274 : Else
12275 0 : lowloop5 : Do ICRS = IDEB, IFIN
12276 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
12277 0 : JHIG = JHIG + 1
12278 0 : IHIGT (JHIG) = ILOWT (ICRS)
12279 : Else
12280 0 : XWRK1 = XDONT(ILOWT(ICRS))
12281 0 : Do ILOW = IDEB, JLOW
12282 0 : If (eq(XWRK1, XDONT(ILOWT(ILOW)))) &
12283 0 : Cycle lowloop5
12284 : End Do
12285 0 : JLOW = JLOW + 1
12286 0 : ILOWT (JLOW) = ILOWT (ICRS)
12287 0 : If (JLOW >= NORD) Exit
12288 : End If
12289 : End Do lowloop5
12290 : !
12291 0 : Do ICRS = ICRS + 1, IFIN
12292 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
12293 0 : JLOW = JLOW + 1
12294 0 : ILOWT (JLOW) = ILOWT (ICRS)
12295 : End If
12296 : End Do
12297 : End If
12298 : !
12299 : End Select
12300 : ! ______________________________
12301 : !
12302 : End Do
12303 : !
12304 : ! Now, we only need to complete ranking of the 1:NORD set
12305 : ! Assuming NORD is small, we use a simple insertion sort
12306 : !
12307 0 : IRNGT (1) = ILOWT (1)
12308 0 : Do ICRS = 2, NORD
12309 0 : IWRK = ILOWT (ICRS)
12310 0 : XWRK = XDONT (IWRK)
12311 0 : Do IDCR = ICRS - 1, 1, - 1
12312 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
12313 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
12314 : Else
12315 : Exit
12316 : End If
12317 : End Do
12318 0 : IRNGT (IDCR + 1) = IWRK
12319 : End Do
12320 : Return
12321 : !
12322 : !
12323 4 : End Subroutine D_unipar
12324 :
12325 0 : Subroutine R_unipar (XDONT, IRNGT, NORD)
12326 : ! Ranks partially XDONT by IRNGT, up to order NORD at most,
12327 : ! removing duplicate entries
12328 : ! __________________________________________________________
12329 : ! This routine uses a pivoting strategy such as the one of
12330 : ! finding the median based on the quicksort algorithm, but
12331 : ! we skew the pivot choice to try to bring it to NORD as
12332 : ! quickly as possible. It uses 2 temporary arrays, where it
12333 : ! stores the indices of the values smaller than the pivot
12334 : ! (ILOWT), and the indices of values larger than the pivot
12335 : ! that we might still need later on (IHIGT). It iterates
12336 : ! until it can bring the number of values in ILOWT to
12337 : ! exactly NORD, and then uses an insertion sort to rank
12338 : ! this set, since it is supposedly small. At all times, the
12339 : ! NORD first values in ILOWT correspond to distinct values
12340 : ! of the input array.
12341 : ! Michel Olagnon - Feb. 2000
12342 : ! __________________________________________________________
12343 : ! _________________________________________________________
12344 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
12345 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
12346 : Integer(kind = i4), Intent (InOut) :: NORD
12347 : ! __________________________________________________________
12348 0 : Real(kind = sp) :: XPIV, XWRK, XWRK1, XMIN, XMAX, XPIV0
12349 : !
12350 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
12351 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
12352 : Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
12353 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
12354 : !
12355 0 : NDON = SIZE (XDONT)
12356 : !
12357 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
12358 : !
12359 0 : If (NDON < 2) Then
12360 0 : If (NORD >= 1) Then
12361 0 : NORD = 1
12362 0 : IRNGT (1) = 1
12363 : End If
12364 0 : Return
12365 : End If
12366 : !
12367 : ! One chooses a pivot, best estimate possible to put fractile near
12368 : ! mid-point of the set of low values.
12369 : !
12370 0 : Do ICRS = 2, NDON
12371 0 : If (eq(XDONT(ICRS), XDONT(1))) Then
12372 : Cycle
12373 0 : Else If (XDONT(ICRS) < XDONT(1)) Then
12374 0 : ILOWT (1) = ICRS
12375 0 : IHIGT (1) = 1
12376 : Else
12377 0 : ILOWT (1) = 1
12378 0 : IHIGT (1) = ICRS
12379 : End If
12380 0 : If (.true.) Exit ! Exit ! JM
12381 : End Do
12382 : !
12383 0 : If (NDON <= ICRS) Then
12384 0 : NORD = Min (NORD, 2)
12385 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
12386 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
12387 0 : Return
12388 : End If
12389 : !
12390 0 : ICRS = ICRS + 1
12391 0 : JHIG = 1
12392 0 : If (XDONT(ICRS) < XDONT(IHIGT(1))) Then
12393 0 : If (XDONT(ICRS) < XDONT(ILOWT(1))) Then
12394 0 : JHIG = JHIG + 1
12395 0 : IHIGT (JHIG) = IHIGT (1)
12396 0 : IHIGT (1) = ILOWT (1)
12397 0 : ILOWT (1) = ICRS
12398 0 : Else If (XDONT(ICRS) > XDONT(ILOWT(1))) Then
12399 0 : JHIG = JHIG + 1
12400 0 : IHIGT (JHIG) = IHIGT (1)
12401 0 : IHIGT (1) = ICRS
12402 : End If
12403 0 : ElseIf (XDONT(ICRS) > XDONT(IHIGT(1))) Then
12404 0 : JHIG = JHIG + 1
12405 0 : IHIGT (JHIG) = ICRS
12406 : End If
12407 : !
12408 0 : If (NDON <= ICRS) Then
12409 0 : NORD = Min (NORD, JHIG + 1)
12410 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
12411 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
12412 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
12413 0 : Return
12414 : End If
12415 : !
12416 0 : If (XDONT(NDON) < XDONT(IHIGT(1))) Then
12417 0 : If (XDONT(NDON) < XDONT(ILOWT(1))) Then
12418 0 : Do IDCR = JHIG, 1, -1
12419 0 : IHIGT (IDCR + 1) = IHIGT (IDCR)
12420 : End Do
12421 0 : IHIGT (1) = ILOWT (1)
12422 0 : ILOWT (1) = NDON
12423 0 : JHIG = JHIG + 1
12424 0 : ElseIf (XDONT(NDON) > XDONT(ILOWT(1))) Then
12425 0 : Do IDCR = JHIG, 1, -1
12426 0 : IHIGT (IDCR + 1) = IHIGT (IDCR)
12427 : End Do
12428 0 : IHIGT (1) = NDON
12429 0 : JHIG = JHIG + 1
12430 : End If
12431 0 : ElseIf (XDONT(NDON) > XDONT(IHIGT(1))) Then
12432 0 : JHIG = JHIG + 1
12433 0 : IHIGT (JHIG) = NDON
12434 : End If
12435 : !
12436 0 : If (NDON <= ICRS + 1) Then
12437 0 : NORD = Min (NORD, JHIG + 1)
12438 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
12439 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
12440 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
12441 0 : If (NORD >= 4) IRNGT (4) = IHIGT (3)
12442 0 : Return
12443 : End If
12444 : !
12445 0 : JDEB = 0
12446 0 : IDEB = JDEB + 1
12447 0 : JLOW = IDEB
12448 0 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, sp) / REAL(NDON + NORD, sp) * &
12449 0 : (XDONT(IHIGT(3)) - XDONT(ILOWT(IDEB)))
12450 0 : If (XPIV >= XDONT(IHIGT(1))) Then
12451 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, sp) / REAL(NDON + NORD, sp) * &
12452 0 : (XDONT(IHIGT(2)) - XDONT(ILOWT(IDEB)))
12453 0 : If (XPIV >= XDONT(IHIGT(1))) &
12454 : XPIV = XDONT (ILOWT(IDEB)) + REAL(2 * NORD, sp) / REAL(NDON + NORD, sp) * &
12455 0 : (XDONT(IHIGT(1)) - XDONT(ILOWT(IDEB)))
12456 : End If
12457 0 : XPIV0 = XPIV
12458 : !
12459 : ! One puts values > pivot in the end and those <= pivot
12460 : ! at the beginning. This is split in 2 cases, so that
12461 : ! we can skip the loop test a number of times.
12462 : ! As we are also filling in the work arrays at the same time
12463 : ! we stop filling in the IHIGT array as soon as we have more
12464 : ! than enough values in ILOWT, i.e. one more than
12465 : ! strictly necessary so as to be able to come out of the
12466 : ! case where JLOWT would be NORD distinct values followed
12467 : ! by values that are exclusively duplicates of these.
12468 : !
12469 : !
12470 0 : If (XDONT(NDON) > XPIV) Then
12471 : lowloop1 : Do
12472 0 : ICRS = ICRS + 1
12473 0 : If (XDONT(ICRS) > XPIV) Then
12474 0 : If (ICRS >= NDON) Exit
12475 0 : JHIG = JHIG + 1
12476 0 : IHIGT (JHIG) = ICRS
12477 : Else
12478 0 : Do ILOW = 1, JLOW
12479 0 : If (eq(XDONT(ICRS), XDONT(ILOWT(ILOW)))) Cycle lowloop1
12480 : End Do
12481 0 : JLOW = JLOW + 1
12482 0 : ILOWT (JLOW) = ICRS
12483 0 : If (JLOW >= NORD) Exit
12484 : End If
12485 : End Do lowloop1
12486 : !
12487 : ! One restricts further processing because it is no use
12488 : ! to store more high values
12489 : !
12490 0 : If (ICRS < NDON - 1) Then
12491 : Do
12492 0 : ICRS = ICRS + 1
12493 0 : If (XDONT(ICRS) <= XPIV) Then
12494 0 : JLOW = JLOW + 1
12495 0 : ILOWT (JLOW) = ICRS
12496 0 : Else If (ICRS >= NDON) Then
12497 : Exit
12498 : End If
12499 : End Do
12500 : End If
12501 : !
12502 : !
12503 : Else
12504 : !
12505 : ! Same as above, but this is not as easy to optimize, so the
12506 : ! DO-loop is kept
12507 : !
12508 0 : lowloop2 : Do ICRS = ICRS + 1, NDON - 1
12509 0 : If (XDONT(ICRS) > XPIV) Then
12510 0 : JHIG = JHIG + 1
12511 0 : IHIGT (JHIG) = ICRS
12512 : Else
12513 0 : Do ILOW = 1, JLOW
12514 0 : If (eq(XDONT(ICRS), XDONT (ILOWT(ILOW)))) Cycle lowloop2
12515 : End Do
12516 0 : JLOW = JLOW + 1
12517 0 : ILOWT (JLOW) = ICRS
12518 0 : If (JLOW >= NORD) Exit
12519 : End If
12520 : End Do lowloop2
12521 : !
12522 0 : If (ICRS < NDON - 1) Then
12523 : Do
12524 0 : ICRS = ICRS + 1
12525 0 : If (XDONT(ICRS) <= XPIV) Then
12526 0 : If (ICRS >= NDON) Exit
12527 0 : JLOW = JLOW + 1
12528 0 : ILOWT (JLOW) = ICRS
12529 : End If
12530 : End Do
12531 : End If
12532 : End If
12533 : !
12534 : JLM2 = 0
12535 : JLM1 = 0
12536 : JHM2 = 0
12537 : JHM1 = 0
12538 : Do
12539 0 : if (JLOW == NORD) Exit
12540 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
12541 : !
12542 : ! We are oscillating. Perturbate by bringing JLOW closer by one
12543 : ! to NORD
12544 : !
12545 0 : If (NORD > JLOW) Then
12546 0 : XMIN = XDONT (IHIGT(1))
12547 0 : IHIG = 1
12548 0 : Do ICRS = 2, JHIG
12549 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
12550 0 : XMIN = XDONT (IHIGT(ICRS))
12551 0 : IHIG = ICRS
12552 : End If
12553 : End Do
12554 : !
12555 0 : JLOW = JLOW + 1
12556 0 : ILOWT (JLOW) = IHIGT (IHIG)
12557 0 : IHIG = 0
12558 0 : Do ICRS = 1, JHIG
12559 0 : If (ne(XDONT(IHIGT (ICRS)), XMIN)) then
12560 0 : IHIG = IHIG + 1
12561 0 : IHIGT (IHIG) = IHIGT (ICRS)
12562 : End If
12563 : End Do
12564 : JHIG = IHIG
12565 : Else
12566 0 : ILOW = ILOWT (JLOW)
12567 0 : XMAX = XDONT (ILOW)
12568 0 : Do ICRS = 1, JLOW
12569 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
12570 0 : IWRK = ILOWT (ICRS)
12571 0 : XMAX = XDONT (IWRK)
12572 0 : ILOWT (ICRS) = ILOW
12573 0 : ILOW = IWRK
12574 : End If
12575 : End Do
12576 0 : JLOW = JLOW - 1
12577 : End If
12578 : End If
12579 0 : JLM2 = JLM1
12580 0 : JLM1 = JLOW
12581 0 : JHM2 = JHM1
12582 0 : JHM1 = JHIG
12583 : !
12584 : ! We try to bring the number of values in the low values set
12585 : ! closer to NORD. In order to make better pivot choices, we
12586 : ! decrease NORD if we already know that we don't have that
12587 : ! many distinct values as a whole.
12588 : !
12589 0 : IF (JLOW + JHIG < NORD) NORD = JLOW + JHIG
12590 0 : Select Case (NORD - JLOW)
12591 : ! ______________________________
12592 : Case (2 :)
12593 : !
12594 : ! Not enough values in low part, at least 2 are missing
12595 : !
12596 0 : Select Case (JHIG)
12597 : !
12598 : ! Not enough values in high part either (too many duplicates)
12599 : !
12600 : Case (0)
12601 0 : NORD = JLOW
12602 : !
12603 : Case (1)
12604 0 : JLOW = JLOW + 1
12605 0 : ILOWT (JLOW) = IHIGT (1)
12606 0 : NORD = JLOW
12607 : !
12608 : ! We make a special case when we have so few values in
12609 : ! the high values set that it is bad performance to choose a pivot
12610 : ! and apply the general algorithm.
12611 : !
12612 : Case (2)
12613 0 : If (le(XDONT(IHIGT(1)), XDONT(IHIGT(2)))) Then
12614 0 : JLOW = JLOW + 1
12615 0 : ILOWT (JLOW) = IHIGT (1)
12616 0 : JLOW = JLOW + 1
12617 0 : ILOWT (JLOW) = IHIGT (2)
12618 0 : ElseIf (eq(XDONT(IHIGT(1)), XDONT(IHIGT(2)))) Then
12619 0 : JLOW = JLOW + 1
12620 0 : ILOWT (JLOW) = IHIGT (1)
12621 0 : NORD = JLOW
12622 : Else
12623 0 : JLOW = JLOW + 1
12624 0 : ILOWT (JLOW) = IHIGT (2)
12625 0 : JLOW = JLOW + 1
12626 0 : ILOWT (JLOW) = IHIGT (1)
12627 : End If
12628 : Exit
12629 : !
12630 : Case (3)
12631 : !
12632 : !
12633 0 : IWRK1 = IHIGT (1)
12634 0 : IWRK2 = IHIGT (2)
12635 0 : IWRK3 = IHIGT (3)
12636 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
12637 0 : IHIGT (1) = IWRK2
12638 0 : IHIGT (2) = IWRK1
12639 0 : IWRK2 = IWRK1
12640 : End If
12641 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
12642 0 : IHIGT (3) = IWRK2
12643 0 : IHIGT (2) = IWRK3
12644 0 : IWRK2 = IWRK3
12645 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
12646 0 : IHIGT (2) = IHIGT (1)
12647 0 : IHIGT (1) = IWRK2
12648 : End If
12649 : End If
12650 0 : JHIG = 1
12651 0 : JLOW = JLOW + 1
12652 0 : ILOWT (JLOW) = IHIGT (1)
12653 0 : JHIG = JHIG + 1
12654 0 : IF (ne(XDONT(IHIGT(JHIG)), XDONT(ILOWT(JLOW)))) Then
12655 0 : JLOW = JLOW + 1
12656 0 : ILOWT (JLOW) = IHIGT (JHIG)
12657 : End If
12658 0 : JHIG = JHIG + 1
12659 0 : IF (ne(XDONT(IHIGT(JHIG)), XDONT(ILOWT(JLOW)))) Then
12660 0 : JLOW = JLOW + 1
12661 0 : ILOWT (JLOW) = IHIGT (JHIG)
12662 : End If
12663 0 : NORD = Min (JLOW, NORD)
12664 0 : Exit
12665 : !
12666 : Case (4 :)
12667 : !
12668 : !
12669 0 : XPIV0 = XPIV
12670 0 : IFIN = JHIG
12671 : !
12672 : ! One chooses a pivot from the 2 first values and the last one.
12673 : ! This should ensure sufficient renewal between iterations to
12674 : ! avoid worst case behavior effects.
12675 : !
12676 0 : IWRK1 = IHIGT (1)
12677 0 : IWRK2 = IHIGT (2)
12678 0 : IWRK3 = IHIGT (IFIN)
12679 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
12680 0 : IHIGT (1) = IWRK2
12681 0 : IHIGT (2) = IWRK1
12682 0 : IWRK2 = IWRK1
12683 : End If
12684 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
12685 0 : IHIGT (IFIN) = IWRK2
12686 0 : IHIGT (2) = IWRK3
12687 0 : IWRK2 = IWRK3
12688 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
12689 0 : IHIGT (2) = IHIGT (1)
12690 0 : IHIGT (1) = IWRK2
12691 : End If
12692 : End If
12693 : !
12694 0 : JDEB = JLOW
12695 0 : NWRK = NORD - JLOW
12696 0 : IWRK1 = IHIGT (1)
12697 0 : XPIV = XDONT (IWRK1) + REAL(NWRK, sp) / REAL(NORD + NWRK, sp) * &
12698 0 : (XDONT(IHIGT(IFIN)) - XDONT(IWRK1))
12699 : !
12700 : ! One takes values <= pivot to ILOWT
12701 : ! Again, 2 parts, one where we take care of the remaining
12702 : ! high values because we might still need them, and the
12703 : ! other when we know that we will have more than enough
12704 : ! low values in the end.
12705 : !
12706 0 : JHIG = 0
12707 0 : lowloop3 : Do ICRS = 1, IFIN
12708 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
12709 0 : Do ILOW = 1, JLOW
12710 0 : If (eq(XDONT(IHIGT(ICRS)), XDONT (ILOWT(ILOW)))) &
12711 0 : Cycle lowloop3
12712 : End Do
12713 0 : JLOW = JLOW + 1
12714 0 : ILOWT (JLOW) = IHIGT (ICRS)
12715 0 : If (JLOW > NORD) Exit
12716 : Else
12717 0 : JHIG = JHIG + 1
12718 0 : IHIGT (JHIG) = IHIGT (ICRS)
12719 : End If
12720 : End Do lowloop3
12721 : !
12722 0 : Do ICRS = ICRS + 1, IFIN
12723 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
12724 0 : JLOW = JLOW + 1
12725 0 : ILOWT (JLOW) = IHIGT (ICRS)
12726 : End If
12727 : End Do
12728 : End Select
12729 : !
12730 : ! ______________________________
12731 : !
12732 : Case (1)
12733 : !
12734 : ! Only 1 value is missing in low part
12735 : !
12736 0 : XMIN = XDONT (IHIGT(1))
12737 0 : IHIG = 1
12738 0 : Do ICRS = 2, JHIG
12739 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
12740 0 : XMIN = XDONT (IHIGT(ICRS))
12741 0 : IHIG = ICRS
12742 : End If
12743 : End Do
12744 : !
12745 0 : JLOW = JLOW + 1
12746 0 : ILOWT (JLOW) = IHIGT (IHIG)
12747 0 : Exit
12748 : !
12749 : ! ______________________________
12750 : !
12751 : Case (0)
12752 : !
12753 : ! Low part is exactly what we want
12754 : !
12755 0 : Exit
12756 : !
12757 : ! ______________________________
12758 : !
12759 : Case (-5 : -1)
12760 : !
12761 : ! Only few values too many in low part
12762 : !
12763 0 : IRNGT (1) = ILOWT (1)
12764 0 : Do ICRS = 2, NORD
12765 0 : IWRK = ILOWT (ICRS)
12766 0 : XWRK = XDONT (IWRK)
12767 0 : Do IDCR = ICRS - 1, 1, - 1
12768 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
12769 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
12770 : Else
12771 : Exit
12772 : End If
12773 : End Do
12774 0 : IRNGT (IDCR + 1) = IWRK
12775 : End Do
12776 : !
12777 0 : XWRK1 = XDONT (IRNGT(NORD))
12778 0 : insert1 : Do ICRS = NORD + 1, JLOW
12779 0 : If (XDONT(ILOWT (ICRS)) < XWRK1) Then
12780 0 : XWRK = XDONT (ILOWT (ICRS))
12781 0 : Do ILOW = 1, NORD - 1
12782 0 : If (XWRK <= XDONT(IRNGT(ILOW))) Then
12783 0 : If (eq(XWRK, XDONT(IRNGT(ILOW)))) Cycle insert1
12784 : Exit
12785 : End If
12786 : End Do
12787 0 : Do IDCR = NORD - 1, ILOW, - 1
12788 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
12789 : End Do
12790 0 : IRNGT (IDCR + 1) = ILOWT (ICRS)
12791 0 : XWRK1 = XDONT (IRNGT(NORD))
12792 : End If
12793 : End Do insert1
12794 : !
12795 0 : Return
12796 : !
12797 : ! ______________________________
12798 : !
12799 : Case (: -6)
12800 : !
12801 : ! last case: too many values in low part
12802 : !
12803 0 : IDEB = JDEB + 1
12804 0 : IMIL = MIN ((JLOW + IDEB) / 2, NORD)
12805 0 : IFIN = MIN (JLOW, NORD + 1)
12806 : !
12807 : ! One chooses a pivot from 1st, last, and middle values
12808 : !
12809 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
12810 0 : IWRK = ILOWT (IDEB)
12811 0 : ILOWT (IDEB) = ILOWT (IMIL)
12812 0 : ILOWT (IMIL) = IWRK
12813 : End If
12814 0 : If (XDONT(ILOWT(IMIL)) > XDONT(ILOWT(IFIN))) Then
12815 0 : IWRK = ILOWT (IFIN)
12816 0 : ILOWT (IFIN) = ILOWT (IMIL)
12817 0 : ILOWT (IMIL) = IWRK
12818 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
12819 0 : IWRK = ILOWT (IDEB)
12820 0 : ILOWT (IDEB) = ILOWT (IMIL)
12821 0 : ILOWT (IMIL) = IWRK
12822 : End If
12823 : End If
12824 0 : If (IFIN <= 3) Exit
12825 : !
12826 0 : XPIV = XDONT (ILOWT(IDEB)) + REAL(NORD, sp) / REAL(JLOW + NORD, sp) * &
12827 0 : (XDONT(ILOWT(IFIN)) - XDONT(ILOWT(1)))
12828 0 : If (JDEB > 0) Then
12829 0 : If (XPIV <= XPIV0) &
12830 : XPIV = XPIV0 + REAL(2 * NORD - JDEB, sp) / REAL(JLOW + NORD, sp) * &
12831 0 : (XDONT(ILOWT(IFIN)) - XPIV0)
12832 : Else
12833 : IDEB = 1
12834 : End If
12835 : !
12836 : ! One takes values > XPIV to IHIGT
12837 : ! However, we do not process the first values if we have been
12838 : ! through the case when we did not have enough low values
12839 : !
12840 0 : JHIG = 0
12841 0 : IFIN = JLOW
12842 0 : JLOW = JDEB
12843 : !
12844 0 : If (XDONT(ILOWT(IFIN)) > XPIV) Then
12845 : ICRS = JDEB
12846 : lowloop4 : Do
12847 0 : ICRS = ICRS + 1
12848 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
12849 0 : JHIG = JHIG + 1
12850 0 : IHIGT (JHIG) = ILOWT (ICRS)
12851 0 : If (ICRS >= IFIN) Exit
12852 : Else
12853 0 : XWRK1 = XDONT(ILOWT(ICRS))
12854 0 : Do ILOW = IDEB, JLOW
12855 0 : If (eq(XWRK1, XDONT(ILOWT(ILOW)))) &
12856 0 : Cycle lowloop4
12857 : End Do
12858 0 : JLOW = JLOW + 1
12859 0 : ILOWT (JLOW) = ILOWT (ICRS)
12860 0 : If (JLOW >= NORD) Exit
12861 : End If
12862 : End Do lowloop4
12863 : !
12864 0 : If (ICRS < IFIN) Then
12865 : Do
12866 0 : ICRS = ICRS + 1
12867 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
12868 0 : JLOW = JLOW + 1
12869 0 : ILOWT (JLOW) = ILOWT (ICRS)
12870 : Else
12871 0 : If (ICRS >= IFIN) Exit
12872 : End If
12873 : End Do
12874 : End If
12875 : Else
12876 0 : lowloop5 : Do ICRS = IDEB, IFIN
12877 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
12878 0 : JHIG = JHIG + 1
12879 0 : IHIGT (JHIG) = ILOWT (ICRS)
12880 : Else
12881 0 : XWRK1 = XDONT(ILOWT(ICRS))
12882 0 : Do ILOW = IDEB, JLOW
12883 0 : If (eq(XWRK1, XDONT(ILOWT(ILOW)))) &
12884 0 : Cycle lowloop5
12885 : End Do
12886 0 : JLOW = JLOW + 1
12887 0 : ILOWT (JLOW) = ILOWT (ICRS)
12888 0 : If (JLOW >= NORD) Exit
12889 : End If
12890 : End Do lowloop5
12891 : !
12892 0 : Do ICRS = ICRS + 1, IFIN
12893 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
12894 0 : JLOW = JLOW + 1
12895 0 : ILOWT (JLOW) = ILOWT (ICRS)
12896 : End If
12897 : End Do
12898 : End If
12899 : !
12900 : End Select
12901 : ! ______________________________
12902 : !
12903 : End Do
12904 : !
12905 : ! Now, we only need to complete ranking of the 1:NORD set
12906 : ! Assuming NORD is small, we use a simple insertion sort
12907 : !
12908 0 : IRNGT (1) = ILOWT (1)
12909 0 : Do ICRS = 2, NORD
12910 0 : IWRK = ILOWT (ICRS)
12911 0 : XWRK = XDONT (IWRK)
12912 0 : Do IDCR = ICRS - 1, 1, - 1
12913 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
12914 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
12915 : Else
12916 : Exit
12917 : End If
12918 : End Do
12919 0 : IRNGT (IDCR + 1) = IWRK
12920 : End Do
12921 : Return
12922 : !
12923 : !
12924 0 : End Subroutine R_unipar
12925 :
12926 0 : Subroutine I_unipar (XDONT, IRNGT, NORD)
12927 : ! Ranks partially XDONT by IRNGT, up to order NORD at most,
12928 : ! removing duplicate entries
12929 : ! __________________________________________________________
12930 : ! This routine uses a pivoting strategy such as the one of
12931 : ! finding the median based on the quicksort algorithm, but
12932 : ! we skew the pivot choice to try to bring it to NORD as
12933 : ! quickly as possible. It uses 2 temporary arrays, where it
12934 : ! stores the indices of the values smaller than the pivot
12935 : ! (ILOWT), and the indices of values larger than the pivot
12936 : ! that we might still need later on (IHIGT). It iterates
12937 : ! until it can bring the number of values in ILOWT to
12938 : ! exactly NORD, and then uses an insertion sort to rank
12939 : ! this set, since it is supposedly small. At all times, the
12940 : ! NORD first values in ILOWT correspond to distinct values
12941 : ! of the input array.
12942 : ! Michel Olagnon - Feb. 2000
12943 : ! __________________________________________________________
12944 : ! __________________________________________________________
12945 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
12946 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
12947 : Integer(kind = i4), Intent (InOut) :: NORD
12948 : ! __________________________________________________________
12949 : Integer(kind = i4) :: XPIV, XWRK, XWRK1, XMIN, XMAX, XPIV0
12950 : !
12951 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
12952 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
12953 : Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
12954 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
12955 : !
12956 0 : NDON = SIZE (XDONT)
12957 : !
12958 : ! First loop is used to fill-in ILOWT, IHIGT at the same time
12959 : !
12960 0 : If (NDON < 2) Then
12961 0 : If (NORD >= 1) Then
12962 0 : NORD = 1
12963 0 : IRNGT (1) = 1
12964 : End If
12965 0 : Return
12966 : End If
12967 : !
12968 : ! One chooses a pivot, best estimate possible to put fractile near
12969 : ! mid-point of the set of low values.
12970 : !
12971 0 : Do ICRS = 2, NDON
12972 0 : If (XDONT(ICRS) == XDONT(1)) Then
12973 : Cycle
12974 0 : Else If (XDONT(ICRS) < XDONT(1)) Then
12975 0 : ILOWT (1) = ICRS
12976 0 : IHIGT (1) = 1
12977 : Else
12978 0 : ILOWT (1) = 1
12979 0 : IHIGT (1) = ICRS
12980 : End If
12981 0 : If (.true.) Exit ! Exit ! JM
12982 : End Do
12983 : !
12984 0 : If (NDON <= ICRS) Then
12985 0 : NORD = Min (NORD, 2)
12986 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
12987 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
12988 0 : Return
12989 : End If
12990 : !
12991 0 : ICRS = ICRS + 1
12992 0 : JHIG = 1
12993 0 : If (XDONT(ICRS) < XDONT(IHIGT(1))) Then
12994 0 : If (XDONT(ICRS) < XDONT(ILOWT(1))) Then
12995 0 : JHIG = JHIG + 1
12996 0 : IHIGT (JHIG) = IHIGT (1)
12997 0 : IHIGT (1) = ILOWT (1)
12998 0 : ILOWT (1) = ICRS
12999 0 : Else If (XDONT(ICRS) > XDONT(ILOWT(1))) Then
13000 0 : JHIG = JHIG + 1
13001 0 : IHIGT (JHIG) = IHIGT (1)
13002 0 : IHIGT (1) = ICRS
13003 : End If
13004 0 : ElseIf (XDONT(ICRS) > XDONT(IHIGT(1))) Then
13005 0 : JHIG = JHIG + 1
13006 0 : IHIGT (JHIG) = ICRS
13007 : End If
13008 : !
13009 0 : If (NDON <= ICRS) Then
13010 0 : NORD = Min (NORD, JHIG + 1)
13011 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
13012 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
13013 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
13014 0 : Return
13015 : End If
13016 : !
13017 0 : If (XDONT(NDON) < XDONT(IHIGT(1))) Then
13018 0 : If (XDONT(NDON) < XDONT(ILOWT(1))) Then
13019 0 : Do IDCR = JHIG, 1, -1
13020 0 : IHIGT (IDCR + 1) = IHIGT (IDCR)
13021 : End Do
13022 0 : IHIGT (1) = ILOWT (1)
13023 0 : ILOWT (1) = NDON
13024 0 : JHIG = JHIG + 1
13025 0 : ElseIf (XDONT(NDON) > XDONT(ILOWT(1))) Then
13026 0 : Do IDCR = JHIG, 1, -1
13027 0 : IHIGT (IDCR + 1) = IHIGT (IDCR)
13028 : End Do
13029 0 : IHIGT (1) = NDON
13030 0 : JHIG = JHIG + 1
13031 : End If
13032 0 : ElseIf (XDONT(NDON) > XDONT(IHIGT(1))) Then
13033 0 : JHIG = JHIG + 1
13034 0 : IHIGT (JHIG) = NDON
13035 : End If
13036 : !
13037 0 : If (NDON <= ICRS + 1) Then
13038 0 : NORD = Min (NORD, JHIG + 1)
13039 0 : If (NORD >= 1) IRNGT (1) = ILOWT (1)
13040 0 : If (NORD >= 2) IRNGT (2) = IHIGT (1)
13041 0 : If (NORD >= 3) IRNGT (3) = IHIGT (2)
13042 0 : If (NORD >= 4) IRNGT (4) = IHIGT (3)
13043 0 : Return
13044 : End If
13045 : !
13046 0 : JDEB = 0
13047 0 : IDEB = JDEB + 1
13048 0 : JLOW = IDEB
13049 0 : XPIV = XDONT (ILOWT(IDEB)) + INT(REAL(2 * NORD, sp) / REAL(NDON + NORD, sp), i4) * &
13050 0 : (XDONT(IHIGT(3)) - XDONT(ILOWT(IDEB)))
13051 0 : If (XPIV >= XDONT(IHIGT(1))) Then
13052 : XPIV = XDONT (ILOWT(IDEB)) + INT(REAL(2 * NORD, sp) / REAL(NDON + NORD, sp), i4) * &
13053 0 : (XDONT(IHIGT(2)) - XDONT(ILOWT(IDEB)))
13054 0 : If (XPIV >= XDONT(IHIGT(1))) &
13055 : XPIV = XDONT (ILOWT(IDEB)) + INT(REAL(2 * NORD, sp) / REAL(NDON + NORD, sp), i4) * &
13056 0 : (XDONT(IHIGT(1)) - XDONT(ILOWT(IDEB)))
13057 : End If
13058 0 : XPIV0 = XPIV
13059 : !
13060 : ! One puts values > pivot in the end and those <= pivot
13061 : ! at the beginning. This is split in 2 cases, so that
13062 : ! we can skip the loop test a number of times.
13063 : ! As we are also filling in the work arrays at the same time
13064 : ! we stop filling in the IHIGT array as soon as we have more
13065 : ! than enough values in ILOWT, i.e. one more than
13066 : ! strictly necessary so as to be able to come out of the
13067 : ! case where JLOWT would be NORD distinct values followed
13068 : ! by values that are exclusively duplicates of these.
13069 : !
13070 : !
13071 0 : If (XDONT(NDON) > XPIV) Then
13072 : lowloop1 : Do
13073 0 : ICRS = ICRS + 1
13074 0 : If (XDONT(ICRS) > XPIV) Then
13075 0 : If (ICRS >= NDON) Exit
13076 0 : JHIG = JHIG + 1
13077 0 : IHIGT (JHIG) = ICRS
13078 : Else
13079 0 : Do ILOW = 1, JLOW
13080 0 : If (XDONT(ICRS) == XDONT(ILOWT(ILOW))) Cycle lowloop1
13081 : End Do
13082 0 : JLOW = JLOW + 1
13083 0 : ILOWT (JLOW) = ICRS
13084 0 : If (JLOW >= NORD) Exit
13085 : End If
13086 : End Do lowloop1
13087 : !
13088 : ! One restricts further processing because it is no use
13089 : ! to store more high values
13090 : !
13091 0 : If (ICRS < NDON - 1) Then
13092 : Do
13093 0 : ICRS = ICRS + 1
13094 0 : If (XDONT(ICRS) <= XPIV) Then
13095 0 : JLOW = JLOW + 1
13096 0 : ILOWT (JLOW) = ICRS
13097 0 : Else If (ICRS >= NDON) Then
13098 : Exit
13099 : End If
13100 : End Do
13101 : End If
13102 : !
13103 : !
13104 : Else
13105 : !
13106 : ! Same as above, but this is not as easy to optimize, so the
13107 : ! DO-loop is kept
13108 : !
13109 0 : lowloop2 : Do ICRS = ICRS + 1, NDON - 1
13110 0 : If (XDONT(ICRS) > XPIV) Then
13111 0 : JHIG = JHIG + 1
13112 0 : IHIGT (JHIG) = ICRS
13113 : Else
13114 0 : Do ILOW = 1, JLOW
13115 0 : If (XDONT(ICRS) == XDONT (ILOWT(ILOW))) Cycle lowloop2
13116 : End Do
13117 0 : JLOW = JLOW + 1
13118 0 : ILOWT (JLOW) = ICRS
13119 0 : If (JLOW >= NORD) Exit
13120 : End If
13121 : End Do lowloop2
13122 : !
13123 0 : If (ICRS < NDON - 1) Then
13124 : Do
13125 0 : ICRS = ICRS + 1
13126 0 : If (XDONT(ICRS) <= XPIV) Then
13127 0 : If (ICRS >= NDON) Exit
13128 0 : JLOW = JLOW + 1
13129 0 : ILOWT (JLOW) = ICRS
13130 : End If
13131 : End Do
13132 : End If
13133 : End If
13134 : !
13135 : JLM2 = 0
13136 : JLM1 = 0
13137 : JHM2 = 0
13138 : JHM1 = 0
13139 : Do
13140 0 : if (JLOW == NORD) Exit
13141 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
13142 : !
13143 : ! We are oscillating. Perturbate by bringing JLOW closer by one
13144 : ! to NORD
13145 : !
13146 0 : If (NORD > JLOW) Then
13147 0 : XMIN = XDONT (IHIGT(1))
13148 0 : IHIG = 1
13149 0 : Do ICRS = 2, JHIG
13150 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
13151 0 : XMIN = XDONT (IHIGT(ICRS))
13152 0 : IHIG = ICRS
13153 : End If
13154 : End Do
13155 : !
13156 0 : JLOW = JLOW + 1
13157 0 : ILOWT (JLOW) = IHIGT (IHIG)
13158 0 : IHIG = 0
13159 0 : Do ICRS = 1, JHIG
13160 0 : If (XDONT(IHIGT (ICRS)) /= XMIN) then
13161 0 : IHIG = IHIG + 1
13162 0 : IHIGT (IHIG) = IHIGT (ICRS)
13163 : End If
13164 : End Do
13165 : JHIG = IHIG
13166 : Else
13167 0 : ILOW = ILOWT (JLOW)
13168 0 : XMAX = XDONT (ILOW)
13169 0 : Do ICRS = 1, JLOW
13170 0 : If (XDONT(ILOWT(ICRS)) > XMAX) Then
13171 0 : IWRK = ILOWT (ICRS)
13172 0 : XMAX = XDONT (IWRK)
13173 0 : ILOWT (ICRS) = ILOW
13174 0 : ILOW = IWRK
13175 : End If
13176 : End Do
13177 0 : JLOW = JLOW - 1
13178 : End If
13179 : End If
13180 0 : JLM2 = JLM1
13181 0 : JLM1 = JLOW
13182 0 : JHM2 = JHM1
13183 0 : JHM1 = JHIG
13184 : !
13185 : ! We try to bring the number of values in the low values set
13186 : ! closer to NORD. In order to make better pivot choices, we
13187 : ! decrease NORD if we already know that we don't have that
13188 : ! many distinct values as a whole.
13189 : !
13190 0 : IF (JLOW + JHIG < NORD) NORD = JLOW + JHIG
13191 0 : Select Case (NORD - JLOW)
13192 : ! ______________________________
13193 : Case (2 :)
13194 : !
13195 : ! Not enough values in low part, at least 2 are missing
13196 : !
13197 0 : Select Case (JHIG)
13198 : !
13199 : ! Not enough values in high part either (too many duplicates)
13200 : !
13201 : Case (0)
13202 0 : NORD = JLOW
13203 : !
13204 : Case (1)
13205 0 : JLOW = JLOW + 1
13206 0 : ILOWT (JLOW) = IHIGT (1)
13207 0 : NORD = JLOW
13208 : !
13209 : ! We make a special case when we have so few values in
13210 : ! the high values set that it is bad performance to choose a pivot
13211 : ! and apply the general algorithm.
13212 : !
13213 : Case (2)
13214 0 : If (XDONT(IHIGT(1)) <= XDONT(IHIGT(2))) Then
13215 0 : JLOW = JLOW + 1
13216 0 : ILOWT (JLOW) = IHIGT (1)
13217 0 : JLOW = JLOW + 1
13218 0 : ILOWT (JLOW) = IHIGT (2)
13219 : ElseIf (XDONT(IHIGT(1)) == XDONT(IHIGT(2))) Then
13220 : JLOW = JLOW + 1
13221 : ILOWT (JLOW) = IHIGT (1)
13222 : NORD = JLOW
13223 : Else
13224 0 : JLOW = JLOW + 1
13225 0 : ILOWT (JLOW) = IHIGT (2)
13226 0 : JLOW = JLOW + 1
13227 0 : ILOWT (JLOW) = IHIGT (1)
13228 : End If
13229 : Exit
13230 : !
13231 : Case (3)
13232 : !
13233 : !
13234 0 : IWRK1 = IHIGT (1)
13235 0 : IWRK2 = IHIGT (2)
13236 0 : IWRK3 = IHIGT (3)
13237 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
13238 0 : IHIGT (1) = IWRK2
13239 0 : IHIGT (2) = IWRK1
13240 0 : IWRK2 = IWRK1
13241 : End If
13242 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
13243 0 : IHIGT (3) = IWRK2
13244 0 : IHIGT (2) = IWRK3
13245 0 : IWRK2 = IWRK3
13246 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
13247 0 : IHIGT (2) = IHIGT (1)
13248 0 : IHIGT (1) = IWRK2
13249 : End If
13250 : End If
13251 0 : JHIG = 1
13252 0 : JLOW = JLOW + 1
13253 0 : ILOWT (JLOW) = IHIGT (1)
13254 0 : JHIG = JHIG + 1
13255 0 : IF (XDONT(IHIGT(JHIG)) /= XDONT(ILOWT(JLOW))) Then
13256 0 : JLOW = JLOW + 1
13257 0 : ILOWT (JLOW) = IHIGT (JHIG)
13258 : End If
13259 0 : JHIG = JHIG + 1
13260 0 : IF (XDONT(IHIGT(JHIG)) /= XDONT(ILOWT(JLOW))) Then
13261 0 : JLOW = JLOW + 1
13262 0 : ILOWT (JLOW) = IHIGT (JHIG)
13263 : End If
13264 0 : NORD = Min (JLOW, NORD)
13265 0 : Exit
13266 : !
13267 : Case (4 :)
13268 : !
13269 : !
13270 0 : XPIV0 = XPIV
13271 0 : IFIN = JHIG
13272 : !
13273 : ! One chooses a pivot from the 2 first values and the last one.
13274 : ! This should ensure sufficient renewal between iterations to
13275 : ! avoid worst case behavior effects.
13276 : !
13277 0 : IWRK1 = IHIGT (1)
13278 0 : IWRK2 = IHIGT (2)
13279 0 : IWRK3 = IHIGT (IFIN)
13280 0 : If (XDONT(IWRK2) < XDONT(IWRK1)) Then
13281 0 : IHIGT (1) = IWRK2
13282 0 : IHIGT (2) = IWRK1
13283 0 : IWRK2 = IWRK1
13284 : End If
13285 0 : If (XDONT(IWRK2) > XDONT(IWRK3)) Then
13286 0 : IHIGT (IFIN) = IWRK2
13287 0 : IHIGT (2) = IWRK3
13288 0 : IWRK2 = IWRK3
13289 0 : If (XDONT(IWRK2) < XDONT(IHIGT(1))) Then
13290 0 : IHIGT (2) = IHIGT (1)
13291 0 : IHIGT (1) = IWRK2
13292 : End If
13293 : End If
13294 : !
13295 0 : JDEB = JLOW
13296 0 : NWRK = NORD - JLOW
13297 0 : IWRK1 = IHIGT (1)
13298 0 : XPIV = XDONT (IWRK1) + INT(REAL(NWRK, sp) / REAL(NORD + NWRK, sp), i4) * &
13299 0 : (XDONT(IHIGT(IFIN)) - XDONT(IWRK1))
13300 : !
13301 : ! One takes values <= pivot to ILOWT
13302 : ! Again, 2 parts, one where we take care of the remaining
13303 : ! high values because we might still need them, and the
13304 : ! other when we know that we will have more than enough
13305 : ! low values in the end.
13306 : !
13307 0 : JHIG = 0
13308 0 : lowloop3 : Do ICRS = 1, IFIN
13309 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
13310 0 : Do ILOW = 1, JLOW
13311 0 : If (XDONT(IHIGT(ICRS)) == XDONT (ILOWT(ILOW))) &
13312 0 : Cycle lowloop3
13313 : End Do
13314 0 : JLOW = JLOW + 1
13315 0 : ILOWT (JLOW) = IHIGT (ICRS)
13316 0 : If (JLOW > NORD) Exit
13317 : Else
13318 0 : JHIG = JHIG + 1
13319 0 : IHIGT (JHIG) = IHIGT (ICRS)
13320 : End If
13321 : End Do lowloop3
13322 : !
13323 0 : Do ICRS = ICRS + 1, IFIN
13324 0 : If (XDONT(IHIGT(ICRS)) <= XPIV) Then
13325 0 : JLOW = JLOW + 1
13326 0 : ILOWT (JLOW) = IHIGT (ICRS)
13327 : End If
13328 : End Do
13329 : End Select
13330 : !
13331 : ! ______________________________
13332 : !
13333 : Case (1)
13334 : !
13335 : ! Only 1 value is missing in low part
13336 : !
13337 0 : XMIN = XDONT (IHIGT(1))
13338 0 : IHIG = 1
13339 0 : Do ICRS = 2, JHIG
13340 0 : If (XDONT(IHIGT(ICRS)) < XMIN) Then
13341 0 : XMIN = XDONT (IHIGT(ICRS))
13342 0 : IHIG = ICRS
13343 : End If
13344 : End Do
13345 : !
13346 0 : JLOW = JLOW + 1
13347 0 : ILOWT (JLOW) = IHIGT (IHIG)
13348 0 : Exit
13349 : !
13350 : ! ______________________________
13351 : !
13352 : Case (0)
13353 : !
13354 : ! Low part is exactly what we want
13355 : !
13356 0 : Exit
13357 : !
13358 : ! ______________________________
13359 : !
13360 : Case (-5 : -1)
13361 : !
13362 : ! Only few values too many in low part
13363 : !
13364 0 : IRNGT (1) = ILOWT (1)
13365 0 : Do ICRS = 2, NORD
13366 0 : IWRK = ILOWT (ICRS)
13367 0 : XWRK = XDONT (IWRK)
13368 0 : Do IDCR = ICRS - 1, 1, - 1
13369 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
13370 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
13371 : Else
13372 : Exit
13373 : End If
13374 : End Do
13375 0 : IRNGT (IDCR + 1) = IWRK
13376 : End Do
13377 : !
13378 0 : XWRK1 = XDONT (IRNGT(NORD))
13379 0 : insert1 : Do ICRS = NORD + 1, JLOW
13380 0 : If (XDONT(ILOWT (ICRS)) < XWRK1) Then
13381 0 : XWRK = XDONT (ILOWT (ICRS))
13382 0 : Do ILOW = 1, NORD - 1
13383 0 : If (XWRK <= XDONT(IRNGT(ILOW))) Then
13384 0 : If (XWRK == XDONT(IRNGT(ILOW))) Cycle insert1
13385 : Exit
13386 : End If
13387 : End Do
13388 0 : Do IDCR = NORD - 1, ILOW, - 1
13389 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
13390 : End Do
13391 0 : IRNGT (IDCR + 1) = ILOWT (ICRS)
13392 0 : XWRK1 = XDONT (IRNGT(NORD))
13393 : End If
13394 : End Do insert1
13395 : !
13396 0 : Return
13397 : !
13398 : ! ______________________________
13399 : !
13400 : Case (: -6)
13401 : !
13402 : ! last case: too many values in low part
13403 : !
13404 0 : IDEB = JDEB + 1
13405 0 : IMIL = MIN ((JLOW + IDEB) / 2, NORD)
13406 0 : IFIN = MIN (JLOW, NORD + 1)
13407 : !
13408 : ! One chooses a pivot from 1st, last, and middle values
13409 : !
13410 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
13411 0 : IWRK = ILOWT (IDEB)
13412 0 : ILOWT (IDEB) = ILOWT (IMIL)
13413 0 : ILOWT (IMIL) = IWRK
13414 : End If
13415 0 : If (XDONT(ILOWT(IMIL)) > XDONT(ILOWT(IFIN))) Then
13416 0 : IWRK = ILOWT (IFIN)
13417 0 : ILOWT (IFIN) = ILOWT (IMIL)
13418 0 : ILOWT (IMIL) = IWRK
13419 0 : If (XDONT(ILOWT(IMIL)) < XDONT(ILOWT(IDEB))) Then
13420 0 : IWRK = ILOWT (IDEB)
13421 0 : ILOWT (IDEB) = ILOWT (IMIL)
13422 0 : ILOWT (IMIL) = IWRK
13423 : End If
13424 : End If
13425 0 : If (IFIN <= 3) Exit
13426 : !
13427 0 : XPIV = XDONT (ILOWT(IDEB)) + INT(REAL(NORD, sp) / REAL(JLOW + NORD, sp), i4) * &
13428 0 : (XDONT(ILOWT(IFIN)) - XDONT(ILOWT(1)))
13429 0 : If (JDEB > 0) Then
13430 0 : If (XPIV <= XPIV0) &
13431 : XPIV = XPIV0 + INT(REAL(2 * NORD - JDEB, sp) / REAL(JLOW + NORD, sp), i4) * &
13432 0 : (XDONT(ILOWT(IFIN)) - XPIV0)
13433 : Else
13434 : IDEB = 1
13435 : End If
13436 : !
13437 : ! One takes values > XPIV to IHIGT
13438 : ! However, we do not process the first values if we have been
13439 : ! through the case when we did not have enough low values
13440 : !
13441 0 : JHIG = 0
13442 0 : IFIN = JLOW
13443 0 : JLOW = JDEB
13444 : !
13445 0 : If (XDONT(ILOWT(IFIN)) > XPIV) Then
13446 : ICRS = JDEB
13447 : lowloop4 : Do
13448 0 : ICRS = ICRS + 1
13449 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
13450 0 : JHIG = JHIG + 1
13451 0 : IHIGT (JHIG) = ILOWT (ICRS)
13452 0 : If (ICRS >= IFIN) Exit
13453 : Else
13454 0 : XWRK1 = XDONT(ILOWT(ICRS))
13455 0 : Do ILOW = IDEB, JLOW
13456 0 : If (XWRK1 == XDONT(ILOWT(ILOW))) &
13457 0 : Cycle lowloop4
13458 : End Do
13459 0 : JLOW = JLOW + 1
13460 0 : ILOWT (JLOW) = ILOWT (ICRS)
13461 0 : If (JLOW >= NORD) Exit
13462 : End If
13463 : End Do lowloop4
13464 : !
13465 0 : If (ICRS < IFIN) Then
13466 : Do
13467 0 : ICRS = ICRS + 1
13468 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
13469 0 : JLOW = JLOW + 1
13470 0 : ILOWT (JLOW) = ILOWT (ICRS)
13471 : Else
13472 0 : If (ICRS >= IFIN) Exit
13473 : End If
13474 : End Do
13475 : End If
13476 : Else
13477 0 : lowloop5 : Do ICRS = IDEB, IFIN
13478 0 : If (XDONT(ILOWT(ICRS)) > XPIV) Then
13479 0 : JHIG = JHIG + 1
13480 0 : IHIGT (JHIG) = ILOWT (ICRS)
13481 : Else
13482 0 : XWRK1 = XDONT(ILOWT(ICRS))
13483 0 : Do ILOW = IDEB, JLOW
13484 0 : If (XWRK1 == XDONT(ILOWT(ILOW))) &
13485 0 : Cycle lowloop5
13486 : End Do
13487 0 : JLOW = JLOW + 1
13488 0 : ILOWT (JLOW) = ILOWT (ICRS)
13489 0 : If (JLOW >= NORD) Exit
13490 : End If
13491 : End Do lowloop5
13492 : !
13493 0 : Do ICRS = ICRS + 1, IFIN
13494 0 : If (XDONT(ILOWT(ICRS)) <= XPIV) Then
13495 0 : JLOW = JLOW + 1
13496 0 : ILOWT (JLOW) = ILOWT (ICRS)
13497 : End If
13498 : End Do
13499 : End If
13500 : !
13501 : End Select
13502 : ! ______________________________
13503 : !
13504 : End Do
13505 : !
13506 : ! Now, we only need to complete ranking of the 1:NORD set
13507 : ! Assuming NORD is small, we use a simple insertion sort
13508 : !
13509 0 : IRNGT (1) = ILOWT (1)
13510 0 : Do ICRS = 2, NORD
13511 0 : IWRK = ILOWT (ICRS)
13512 0 : XWRK = XDONT (IWRK)
13513 0 : Do IDCR = ICRS - 1, 1, - 1
13514 0 : If (XWRK < XDONT(IRNGT(IDCR))) Then
13515 0 : IRNGT (IDCR + 1) = IRNGT (IDCR)
13516 : Else
13517 : Exit
13518 : End If
13519 : End Do
13520 0 : IRNGT (IDCR + 1) = IWRK
13521 : End Do
13522 : Return
13523 : !
13524 : !
13525 0 : End Subroutine I_unipar
13526 :
13527 0 : Subroutine D_unirnk (XVALT, IRNGT, NUNI)
13528 : ! __________________________________________________________
13529 : ! UNIRNK = Merge-sort ranking of an array, with removal of
13530 : ! duplicate entries.
13531 : ! The routine is similar to pure merge-sort ranking, but on
13532 : ! the last pass, it discards indices that correspond to
13533 : ! duplicate entries.
13534 : ! For performance reasons, the first 2 passes are taken
13535 : ! out of the standard loop, and use dedicated coding.
13536 : ! __________________________________________________________
13537 : ! __________________________________________________________
13538 : real(Kind = dp), Dimension (:), Intent (In) :: XVALT
13539 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
13540 : Integer(kind = i4), Intent (Out) :: NUNI
13541 : ! __________________________________________________________
13542 0 : Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
13543 : Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2
13544 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
13545 0 : real(Kind = dp) :: XTST, XVALA, XVALB
13546 : !
13547 : !
13548 0 : NVAL = Min (SIZE(XVALT), SIZE(IRNGT))
13549 0 : NUNI = NVAL
13550 : !
13551 : Select Case (NVAL)
13552 : Case (: 0)
13553 0 : Return
13554 : Case (1)
13555 0 : IRNGT (1) = 1
13556 0 : Return
13557 : Case Default
13558 :
13559 : End Select
13560 : !
13561 : ! Fill-in the index array, creating ordered couples
13562 : !
13563 0 : Do IIND = 2, NVAL, 2
13564 0 : If (XVALT(IIND - 1) < XVALT(IIND)) Then
13565 0 : IRNGT (IIND - 1) = IIND - 1
13566 0 : IRNGT (IIND) = IIND
13567 : Else
13568 0 : IRNGT (IIND - 1) = IIND
13569 0 : IRNGT (IIND) = IIND - 1
13570 : End If
13571 : End Do
13572 0 : If (Modulo(NVAL, 2) /= 0) Then
13573 0 : IRNGT (NVAL) = NVAL
13574 : End If
13575 : !
13576 : ! We will now have ordered subsets A - B - A - B - ...
13577 : ! and merge A and B couples into C - C - ...
13578 : !
13579 0 : LMTNA = 2
13580 0 : LMTNC = 4
13581 : !
13582 : ! First iteration. The length of the ordered subsets goes from 2 to 4
13583 : !
13584 : Do
13585 0 : If (NVAL <= 4) Exit
13586 : !
13587 : ! Loop on merges of A and B into C
13588 : !
13589 0 : Do IWRKD = 0, NVAL - 1, 4
13590 0 : If ((IWRKD + 4) > NVAL) Then
13591 0 : If ((IWRKD + 2) >= NVAL) Exit
13592 : !
13593 : ! 1 2 3
13594 : !
13595 0 : If (XVALT(IRNGT(IWRKD + 2)) <= XVALT(IRNGT(IWRKD + 3))) Exit
13596 : !
13597 : ! 1 3 2
13598 : !
13599 0 : If (XVALT(IRNGT(IWRKD + 1)) <= XVALT(IRNGT(IWRKD + 3))) Then
13600 0 : IRNG2 = IRNGT (IWRKD + 2)
13601 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
13602 0 : IRNGT (IWRKD + 3) = IRNG2
13603 : !
13604 : ! 3 1 2
13605 : !
13606 : Else
13607 0 : IRNG1 = IRNGT (IWRKD + 1)
13608 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
13609 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 2)
13610 0 : IRNGT (IWRKD + 2) = IRNG1
13611 : End If
13612 : If (.true.) Exit ! Exit ! JM
13613 : End If
13614 : !
13615 : ! 1 2 3 4
13616 : !
13617 0 : If (XVALT(IRNGT(IWRKD + 2)) <= XVALT(IRNGT(IWRKD + 3))) Cycle
13618 : !
13619 : ! 1 3 x x
13620 : !
13621 0 : If (XVALT(IRNGT(IWRKD + 1)) <= XVALT(IRNGT(IWRKD + 3))) Then
13622 0 : IRNG2 = IRNGT (IWRKD + 2)
13623 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
13624 0 : If (XVALT(IRNG2) <= XVALT(IRNGT(IWRKD + 4))) Then
13625 : ! 1 3 2 4
13626 0 : IRNGT (IWRKD + 3) = IRNG2
13627 : Else
13628 : ! 1 3 4 2
13629 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
13630 0 : IRNGT (IWRKD + 4) = IRNG2
13631 : End If
13632 : !
13633 : ! 3 x x x
13634 : !
13635 : Else
13636 0 : IRNG1 = IRNGT (IWRKD + 1)
13637 0 : IRNG2 = IRNGT (IWRKD + 2)
13638 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
13639 0 : If (XVALT(IRNG1) <= XVALT(IRNGT(IWRKD + 4))) Then
13640 0 : IRNGT (IWRKD + 2) = IRNG1
13641 0 : If (XVALT(IRNG2) <= XVALT(IRNGT(IWRKD + 4))) Then
13642 : ! 3 1 2 4
13643 0 : IRNGT (IWRKD + 3) = IRNG2
13644 : Else
13645 : ! 3 1 4 2
13646 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
13647 0 : IRNGT (IWRKD + 4) = IRNG2
13648 : End If
13649 : Else
13650 : ! 3 4 1 2
13651 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 4)
13652 0 : IRNGT (IWRKD + 3) = IRNG1
13653 0 : IRNGT (IWRKD + 4) = IRNG2
13654 : End If
13655 : End If
13656 : End Do
13657 : !
13658 : ! The Cs become As and Bs
13659 : !
13660 : LMTNA = 4
13661 0 : If (.true.) Exit ! Exit ! JM
13662 : End Do
13663 : !
13664 : ! Iteration loop. Each time, the length of the ordered subsets
13665 : ! is doubled.
13666 : !
13667 : Do
13668 0 : If (2 * LMTNA >= NVAL) Exit
13669 0 : IWRKF = 0
13670 0 : LMTNC = 2 * LMTNC
13671 : !
13672 : ! Loop on merges of A and B into C
13673 : !
13674 : Do
13675 0 : IWRK = IWRKF
13676 0 : IWRKD = IWRKF + 1
13677 0 : JINDA = IWRKF + LMTNA
13678 0 : IWRKF = IWRKF + LMTNC
13679 0 : If (IWRKF >= NVAL) Then
13680 0 : If (JINDA >= NVAL) Exit
13681 : IWRKF = NVAL
13682 : End If
13683 0 : IINDA = 1
13684 0 : IINDB = JINDA + 1
13685 : !
13686 : ! One steps in the C subset, that we create in the final rank array
13687 : !
13688 : ! Make a copy of the rank array for the iteration
13689 : !
13690 0 : JWRKT (1 : LMTNA) = IRNGT (IWRKD : JINDA)
13691 0 : XVALA = XVALT (JWRKT(IINDA))
13692 0 : XVALB = XVALT (IRNGT(IINDB))
13693 : !
13694 0 : Do
13695 0 : IWRK = IWRK + 1
13696 : !
13697 : ! We still have unprocessed values in both A and B
13698 : !
13699 0 : If (XVALA > XVALB) Then
13700 0 : IRNGT (IWRK) = IRNGT (IINDB)
13701 0 : IINDB = IINDB + 1
13702 0 : If (IINDB > IWRKF) Then
13703 : ! Only A still with unprocessed values
13704 0 : IRNGT (IWRK + 1 : IWRKF) = JWRKT (IINDA : LMTNA)
13705 : Exit
13706 : End If
13707 0 : XVALB = XVALT (IRNGT(IINDB))
13708 : Else
13709 0 : IRNGT (IWRK) = JWRKT (IINDA)
13710 0 : IINDA = IINDA + 1
13711 0 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
13712 0 : XVALA = XVALT (JWRKT(IINDA))
13713 : End If
13714 : !
13715 : End Do
13716 : End Do
13717 : !
13718 : ! The Cs become As and Bs
13719 : !
13720 0 : LMTNA = 2 * LMTNA
13721 : End Do
13722 : !
13723 : ! Last merge of A and B into C, with removal of duplicates.
13724 : !
13725 0 : IINDA = 1
13726 0 : IINDB = LMTNA + 1
13727 0 : NUNI = 0
13728 : !
13729 : ! One steps in the C subset, that we create in the final rank array
13730 : !
13731 0 : JWRKT (1 : LMTNA) = IRNGT (1 : LMTNA)
13732 0 : If (IINDB <= NVAL) Then
13733 0 : XTST = NEARLESS (Min(XVALT(JWRKT(1)), XVALT(IRNGT(IINDB))))
13734 : Else
13735 0 : XTST = NEARLESS (XVALT(JWRKT(1)))
13736 : end if
13737 0 : Do IWRK = 1, NVAL
13738 : !
13739 : ! We still have unprocessed values in both A and B
13740 : !
13741 0 : If (IINDA <= LMTNA) Then
13742 0 : If (IINDB <= NVAL) Then
13743 0 : If (XVALT(JWRKT(IINDA)) > XVALT(IRNGT(IINDB))) Then
13744 0 : IRNG = IRNGT (IINDB)
13745 0 : IINDB = IINDB + 1
13746 : Else
13747 0 : IRNG = JWRKT (IINDA)
13748 0 : IINDA = IINDA + 1
13749 : End If
13750 : Else
13751 : !
13752 : ! Only A still with unprocessed values
13753 : !
13754 0 : IRNG = JWRKT (IINDA)
13755 0 : IINDA = IINDA + 1
13756 : End If
13757 : Else
13758 : !
13759 : ! Only B still with unprocessed values
13760 : !
13761 0 : IRNG = IRNGT (IWRK)
13762 : End If
13763 0 : If (XVALT(IRNG) > XTST) Then
13764 0 : XTST = XVALT (IRNG)
13765 0 : NUNI = NUNI + 1
13766 0 : IRNGT (NUNI) = IRNG
13767 : End If
13768 : !
13769 : End Do
13770 : !
13771 : Return
13772 : !
13773 0 : End Subroutine D_unirnk
13774 :
13775 0 : Subroutine R_unirnk (XVALT, IRNGT, NUNI)
13776 : ! __________________________________________________________
13777 : ! UNIRNK = Merge-sort ranking of an array, with removal of
13778 : ! duplicate entries.
13779 : ! The routine is similar to pure merge-sort ranking, but on
13780 : ! the last pass, it discards indices that correspond to
13781 : ! duplicate entries.
13782 : ! For performance reasons, the first 2 passes are taken
13783 : ! out of the standard loop, and use dedicated coding.
13784 : ! __________________________________________________________
13785 : ! __________________________________________________________
13786 : Real(kind = sp), Dimension (:), Intent (In) :: XVALT
13787 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
13788 : Integer(kind = i4), Intent (Out) :: NUNI
13789 : ! __________________________________________________________
13790 0 : Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
13791 : Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2
13792 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
13793 0 : Real(kind = sp) :: XTST, XVALA, XVALB
13794 : !
13795 : !
13796 0 : NVAL = Min (SIZE(XVALT), SIZE(IRNGT))
13797 0 : NUNI = NVAL
13798 : !
13799 : Select Case (NVAL)
13800 : Case (: 0)
13801 0 : Return
13802 : Case (1)
13803 0 : IRNGT (1) = 1
13804 0 : Return
13805 : Case Default
13806 :
13807 : End Select
13808 : !
13809 : ! Fill-in the index array, creating ordered couples
13810 : !
13811 0 : Do IIND = 2, NVAL, 2
13812 0 : If (XVALT(IIND - 1) < XVALT(IIND)) Then
13813 0 : IRNGT (IIND - 1) = IIND - 1
13814 0 : IRNGT (IIND) = IIND
13815 : Else
13816 0 : IRNGT (IIND - 1) = IIND
13817 0 : IRNGT (IIND) = IIND - 1
13818 : End If
13819 : End Do
13820 0 : If (Modulo(NVAL, 2) /= 0) Then
13821 0 : IRNGT (NVAL) = NVAL
13822 : End If
13823 : !
13824 : ! We will now have ordered subsets A - B - A - B - ...
13825 : ! and merge A and B couples into C - C - ...
13826 : !
13827 0 : LMTNA = 2
13828 0 : LMTNC = 4
13829 : !
13830 : ! First iteration. The length of the ordered subsets goes from 2 to 4
13831 : !
13832 : Do
13833 0 : If (NVAL <= 4) Exit
13834 : !
13835 : ! Loop on merges of A and B into C
13836 : !
13837 0 : Do IWRKD = 0, NVAL - 1, 4
13838 0 : If ((IWRKD + 4) > NVAL) Then
13839 0 : If ((IWRKD + 2) >= NVAL) Exit
13840 : !
13841 : ! 1 2 3
13842 : !
13843 0 : If (XVALT(IRNGT(IWRKD + 2)) <= XVALT(IRNGT(IWRKD + 3))) Exit
13844 : !
13845 : ! 1 3 2
13846 : !
13847 0 : If (XVALT(IRNGT(IWRKD + 1)) <= XVALT(IRNGT(IWRKD + 3))) Then
13848 0 : IRNG2 = IRNGT (IWRKD + 2)
13849 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
13850 0 : IRNGT (IWRKD + 3) = IRNG2
13851 : !
13852 : ! 3 1 2
13853 : !
13854 : Else
13855 0 : IRNG1 = IRNGT (IWRKD + 1)
13856 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
13857 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 2)
13858 0 : IRNGT (IWRKD + 2) = IRNG1
13859 : End If
13860 : If (.true.) Exit ! Exit ! JM
13861 : End If
13862 : !
13863 : ! 1 2 3 4
13864 : !
13865 0 : If (XVALT(IRNGT(IWRKD + 2)) <= XVALT(IRNGT(IWRKD + 3))) Cycle
13866 : !
13867 : ! 1 3 x x
13868 : !
13869 0 : If (XVALT(IRNGT(IWRKD + 1)) <= XVALT(IRNGT(IWRKD + 3))) Then
13870 0 : IRNG2 = IRNGT (IWRKD + 2)
13871 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
13872 0 : If (XVALT(IRNG2) <= XVALT(IRNGT(IWRKD + 4))) Then
13873 : ! 1 3 2 4
13874 0 : IRNGT (IWRKD + 3) = IRNG2
13875 : Else
13876 : ! 1 3 4 2
13877 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
13878 0 : IRNGT (IWRKD + 4) = IRNG2
13879 : End If
13880 : !
13881 : ! 3 x x x
13882 : !
13883 : Else
13884 0 : IRNG1 = IRNGT (IWRKD + 1)
13885 0 : IRNG2 = IRNGT (IWRKD + 2)
13886 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
13887 0 : If (XVALT(IRNG1) <= XVALT(IRNGT(IWRKD + 4))) Then
13888 0 : IRNGT (IWRKD + 2) = IRNG1
13889 0 : If (XVALT(IRNG2) <= XVALT(IRNGT(IWRKD + 4))) Then
13890 : ! 3 1 2 4
13891 0 : IRNGT (IWRKD + 3) = IRNG2
13892 : Else
13893 : ! 3 1 4 2
13894 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
13895 0 : IRNGT (IWRKD + 4) = IRNG2
13896 : End If
13897 : Else
13898 : ! 3 4 1 2
13899 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 4)
13900 0 : IRNGT (IWRKD + 3) = IRNG1
13901 0 : IRNGT (IWRKD + 4) = IRNG2
13902 : End If
13903 : End If
13904 : End Do
13905 : !
13906 : ! The Cs become As and Bs
13907 : !
13908 : LMTNA = 4
13909 0 : If (.true.) Exit ! Exit ! JM
13910 : End Do
13911 : !
13912 : ! Iteration loop. Each time, the length of the ordered subsets
13913 : ! is doubled.
13914 : !
13915 : Do
13916 0 : If (2 * LMTNA >= NVAL) Exit
13917 0 : IWRKF = 0
13918 0 : LMTNC = 2 * LMTNC
13919 : !
13920 : ! Loop on merges of A and B into C
13921 : !
13922 : Do
13923 0 : IWRK = IWRKF
13924 0 : IWRKD = IWRKF + 1
13925 0 : JINDA = IWRKF + LMTNA
13926 0 : IWRKF = IWRKF + LMTNC
13927 0 : If (IWRKF >= NVAL) Then
13928 0 : If (JINDA >= NVAL) Exit
13929 : IWRKF = NVAL
13930 : End If
13931 0 : IINDA = 1
13932 0 : IINDB = JINDA + 1
13933 : !
13934 : ! One steps in the C subset, that we create in the final rank array
13935 : !
13936 : ! Make a copy of the rank array for the iteration
13937 : !
13938 0 : JWRKT (1 : LMTNA) = IRNGT (IWRKD : JINDA)
13939 0 : XVALA = XVALT (JWRKT(IINDA))
13940 0 : XVALB = XVALT (IRNGT(IINDB))
13941 : !
13942 0 : Do
13943 0 : IWRK = IWRK + 1
13944 : !
13945 : ! We still have unprocessed values in both A and B
13946 : !
13947 0 : If (XVALA > XVALB) Then
13948 0 : IRNGT (IWRK) = IRNGT (IINDB)
13949 0 : IINDB = IINDB + 1
13950 0 : If (IINDB > IWRKF) Then
13951 : ! Only A still with unprocessed values
13952 0 : IRNGT (IWRK + 1 : IWRKF) = JWRKT (IINDA : LMTNA)
13953 : Exit
13954 : End If
13955 0 : XVALB = XVALT (IRNGT(IINDB))
13956 : Else
13957 0 : IRNGT (IWRK) = JWRKT (IINDA)
13958 0 : IINDA = IINDA + 1
13959 0 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
13960 0 : XVALA = XVALT (JWRKT(IINDA))
13961 : End If
13962 : !
13963 : End Do
13964 : End Do
13965 : !
13966 : ! The Cs become As and Bs
13967 : !
13968 0 : LMTNA = 2 * LMTNA
13969 : End Do
13970 : !
13971 : ! Last merge of A and B into C, with removal of duplicates.
13972 : !
13973 0 : IINDA = 1
13974 0 : IINDB = LMTNA + 1
13975 0 : NUNI = 0
13976 : !
13977 : ! One steps in the C subset, that we create in the final rank array
13978 : !
13979 0 : JWRKT (1 : LMTNA) = IRNGT (1 : LMTNA)
13980 0 : If (IINDB <= NVAL) Then
13981 0 : XTST = NEARLESS (Min(XVALT(JWRKT(1)), XVALT(IRNGT(IINDB))))
13982 : Else
13983 0 : XTST = NEARLESS (XVALT(JWRKT(1)))
13984 : end if
13985 0 : Do IWRK = 1, NVAL
13986 : !
13987 : ! We still have unprocessed values in both A and B
13988 : !
13989 0 : If (IINDA <= LMTNA) Then
13990 0 : If (IINDB <= NVAL) Then
13991 0 : If (XVALT(JWRKT(IINDA)) > XVALT(IRNGT(IINDB))) Then
13992 0 : IRNG = IRNGT (IINDB)
13993 0 : IINDB = IINDB + 1
13994 : Else
13995 0 : IRNG = JWRKT (IINDA)
13996 0 : IINDA = IINDA + 1
13997 : End If
13998 : Else
13999 : !
14000 : ! Only A still with unprocessed values
14001 : !
14002 0 : IRNG = JWRKT (IINDA)
14003 0 : IINDA = IINDA + 1
14004 : End If
14005 : Else
14006 : !
14007 : ! Only B still with unprocessed values
14008 : !
14009 0 : IRNG = IRNGT (IWRK)
14010 : End If
14011 0 : If (XVALT(IRNG) > XTST) Then
14012 0 : XTST = XVALT (IRNG)
14013 0 : NUNI = NUNI + 1
14014 0 : IRNGT (NUNI) = IRNG
14015 : End If
14016 : !
14017 : End Do
14018 : !
14019 : Return
14020 : !
14021 0 : End Subroutine R_unirnk
14022 :
14023 0 : Subroutine I_unirnk (XVALT, IRNGT, NUNI)
14024 : ! __________________________________________________________
14025 : ! UNIRNK = Merge-sort ranking of an array, with removal of
14026 : ! duplicate entries.
14027 : ! The routine is similar to pure merge-sort ranking, but on
14028 : ! the last pass, it discards indices that correspond to
14029 : ! duplicate entries.
14030 : ! For performance reasons, the first 2 passes are taken
14031 : ! out of the standard loop, and use dedicated coding.
14032 : ! __________________________________________________________
14033 : ! __________________________________________________________
14034 : Integer(kind = i4), Dimension (:), Intent (In) :: XVALT
14035 : Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
14036 : Integer(kind = i4), Intent (Out) :: NUNI
14037 : ! __________________________________________________________
14038 0 : Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
14039 : Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2
14040 : Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
14041 : Integer(kind = i4) :: XTST, XVALA, XVALB
14042 : !
14043 : !
14044 0 : NVAL = Min (SIZE(XVALT), SIZE(IRNGT))
14045 0 : NUNI = NVAL
14046 : !
14047 : Select Case (NVAL)
14048 : Case (: 0)
14049 0 : Return
14050 : Case (1)
14051 0 : IRNGT (1) = 1
14052 0 : Return
14053 : Case Default
14054 :
14055 : End Select
14056 : !
14057 : ! Fill-in the index array, creating ordered couples
14058 : !
14059 0 : Do IIND = 2, NVAL, 2
14060 0 : If (XVALT(IIND - 1) < XVALT(IIND)) Then
14061 0 : IRNGT (IIND - 1) = IIND - 1
14062 0 : IRNGT (IIND) = IIND
14063 : Else
14064 0 : IRNGT (IIND - 1) = IIND
14065 0 : IRNGT (IIND) = IIND - 1
14066 : End If
14067 : End Do
14068 0 : If (Modulo(NVAL, 2) /= 0) Then
14069 0 : IRNGT (NVAL) = NVAL
14070 : End If
14071 : !
14072 : ! We will now have ordered subsets A - B - A - B - ...
14073 : ! and merge A and B couples into C - C - ...
14074 : !
14075 0 : LMTNA = 2
14076 0 : LMTNC = 4
14077 : !
14078 : ! First iteration. The length of the ordered subsets goes from 2 to 4
14079 : !
14080 : Do
14081 0 : If (NVAL <= 4) Exit
14082 : !
14083 : ! Loop on merges of A and B into C
14084 : !
14085 0 : Do IWRKD = 0, NVAL - 1, 4
14086 0 : If ((IWRKD + 4) > NVAL) Then
14087 0 : If ((IWRKD + 2) >= NVAL) Exit
14088 : !
14089 : ! 1 2 3
14090 : !
14091 0 : If (XVALT(IRNGT(IWRKD + 2)) <= XVALT(IRNGT(IWRKD + 3))) Exit
14092 : !
14093 : ! 1 3 2
14094 : !
14095 0 : If (XVALT(IRNGT(IWRKD + 1)) <= XVALT(IRNGT(IWRKD + 3))) Then
14096 0 : IRNG2 = IRNGT (IWRKD + 2)
14097 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
14098 0 : IRNGT (IWRKD + 3) = IRNG2
14099 : !
14100 : ! 3 1 2
14101 : !
14102 : Else
14103 0 : IRNG1 = IRNGT (IWRKD + 1)
14104 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
14105 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 2)
14106 0 : IRNGT (IWRKD + 2) = IRNG1
14107 : End If
14108 : If (.true.) Exit ! Exit ! JM
14109 : End If
14110 : !
14111 : ! 1 2 3 4
14112 : !
14113 0 : If (XVALT(IRNGT(IWRKD + 2)) <= XVALT(IRNGT(IWRKD + 3))) Cycle
14114 : !
14115 : ! 1 3 x x
14116 : !
14117 0 : If (XVALT(IRNGT(IWRKD + 1)) <= XVALT(IRNGT(IWRKD + 3))) Then
14118 0 : IRNG2 = IRNGT (IWRKD + 2)
14119 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 3)
14120 0 : If (XVALT(IRNG2) <= XVALT(IRNGT(IWRKD + 4))) Then
14121 : ! 1 3 2 4
14122 0 : IRNGT (IWRKD + 3) = IRNG2
14123 : Else
14124 : ! 1 3 4 2
14125 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
14126 0 : IRNGT (IWRKD + 4) = IRNG2
14127 : End If
14128 : !
14129 : ! 3 x x x
14130 : !
14131 : Else
14132 0 : IRNG1 = IRNGT (IWRKD + 1)
14133 0 : IRNG2 = IRNGT (IWRKD + 2)
14134 0 : IRNGT (IWRKD + 1) = IRNGT (IWRKD + 3)
14135 0 : If (XVALT(IRNG1) <= XVALT(IRNGT(IWRKD + 4))) Then
14136 0 : IRNGT (IWRKD + 2) = IRNG1
14137 0 : If (XVALT(IRNG2) <= XVALT(IRNGT(IWRKD + 4))) Then
14138 : ! 3 1 2 4
14139 0 : IRNGT (IWRKD + 3) = IRNG2
14140 : Else
14141 : ! 3 1 4 2
14142 0 : IRNGT (IWRKD + 3) = IRNGT (IWRKD + 4)
14143 0 : IRNGT (IWRKD + 4) = IRNG2
14144 : End If
14145 : Else
14146 : ! 3 4 1 2
14147 0 : IRNGT (IWRKD + 2) = IRNGT (IWRKD + 4)
14148 0 : IRNGT (IWRKD + 3) = IRNG1
14149 0 : IRNGT (IWRKD + 4) = IRNG2
14150 : End If
14151 : End If
14152 : End Do
14153 : !
14154 : ! The Cs become As and Bs
14155 : !
14156 : LMTNA = 4
14157 0 : If (.true.) Exit ! Exit ! JM
14158 : End Do
14159 : !
14160 : ! Iteration loop. Each time, the length of the ordered subsets
14161 : ! is doubled.
14162 : !
14163 : Do
14164 0 : If (2 * LMTNA >= NVAL) Exit
14165 0 : IWRKF = 0
14166 0 : LMTNC = 2 * LMTNC
14167 : !
14168 : ! Loop on merges of A and B into C
14169 : !
14170 : Do
14171 0 : IWRK = IWRKF
14172 0 : IWRKD = IWRKF + 1
14173 0 : JINDA = IWRKF + LMTNA
14174 0 : IWRKF = IWRKF + LMTNC
14175 0 : If (IWRKF >= NVAL) Then
14176 0 : If (JINDA >= NVAL) Exit
14177 : IWRKF = NVAL
14178 : End If
14179 0 : IINDA = 1
14180 0 : IINDB = JINDA + 1
14181 : !
14182 : ! One steps in the C subset, that we create in the final rank array
14183 : !
14184 : ! Make a copy of the rank array for the iteration
14185 : !
14186 0 : JWRKT (1 : LMTNA) = IRNGT (IWRKD : JINDA)
14187 0 : XVALA = XVALT (JWRKT(IINDA))
14188 0 : XVALB = XVALT (IRNGT(IINDB))
14189 : !
14190 0 : Do
14191 0 : IWRK = IWRK + 1
14192 : !
14193 : ! We still have unprocessed values in both A and B
14194 : !
14195 0 : If (XVALA > XVALB) Then
14196 0 : IRNGT (IWRK) = IRNGT (IINDB)
14197 0 : IINDB = IINDB + 1
14198 0 : If (IINDB > IWRKF) Then
14199 : ! Only A still with unprocessed values
14200 0 : IRNGT (IWRK + 1 : IWRKF) = JWRKT (IINDA : LMTNA)
14201 : Exit
14202 : End If
14203 0 : XVALB = XVALT (IRNGT(IINDB))
14204 : Else
14205 0 : IRNGT (IWRK) = JWRKT (IINDA)
14206 0 : IINDA = IINDA + 1
14207 0 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
14208 0 : XVALA = XVALT (JWRKT(IINDA))
14209 : End If
14210 : !
14211 : End Do
14212 : End Do
14213 : !
14214 : ! The Cs become As and Bs
14215 : !
14216 0 : LMTNA = 2 * LMTNA
14217 : End Do
14218 : !
14219 : ! Last merge of A and B into C, with removal of duplicates.
14220 : !
14221 0 : IINDA = 1
14222 0 : IINDB = LMTNA + 1
14223 0 : NUNI = 0
14224 : !
14225 : ! One steps in the C subset, that we create in the final rank array
14226 : !
14227 0 : JWRKT (1 : LMTNA) = IRNGT (1 : LMTNA)
14228 0 : If (IINDB <= NVAL) Then
14229 0 : XTST = NEARLESS (Min(XVALT(JWRKT(1)), XVALT(IRNGT(IINDB))))
14230 : Else
14231 0 : XTST = NEARLESS (XVALT(JWRKT(1)))
14232 : end if
14233 0 : Do IWRK = 1, NVAL
14234 : !
14235 : ! We still have unprocessed values in both A and B
14236 : !
14237 0 : If (IINDA <= LMTNA) Then
14238 0 : If (IINDB <= NVAL) Then
14239 0 : If (XVALT(JWRKT(IINDA)) > XVALT(IRNGT(IINDB))) Then
14240 0 : IRNG = IRNGT (IINDB)
14241 0 : IINDB = IINDB + 1
14242 : Else
14243 0 : IRNG = JWRKT (IINDA)
14244 0 : IINDA = IINDA + 1
14245 : End If
14246 : Else
14247 : !
14248 : ! Only A still with unprocessed values
14249 : !
14250 0 : IRNG = JWRKT (IINDA)
14251 0 : IINDA = IINDA + 1
14252 : End If
14253 : Else
14254 : !
14255 : ! Only B still with unprocessed values
14256 : !
14257 0 : IRNG = IRNGT (IWRK)
14258 : End If
14259 0 : If (XVALT(IRNG) > XTST) Then
14260 0 : XTST = XVALT (IRNG)
14261 0 : NUNI = NUNI + 1
14262 0 : IRNGT (NUNI) = IRNG
14263 : End If
14264 : !
14265 : End Do
14266 : !
14267 : Return
14268 : !
14269 0 : End Subroutine I_unirnk
14270 :
14271 :
14272 0 : Subroutine D_unista (XDONT, NUNI)
14273 : ! UNISTA = (Stable unique) Removes duplicates from an array,
14274 : ! leaving unique entries in the order of their first
14275 : ! appearance in the initial set.
14276 : ! Michel Olagnon - Feb. 2000
14277 : ! __________________________________________________________
14278 : ! __________________________________________________________
14279 : real(kind = dp), Dimension (:), Intent (InOut) :: XDONT
14280 : Integer(kind = i4), Intent (Out) :: NUNI
14281 : ! __________________________________________________________
14282 : !
14283 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
14284 0 : Logical, Dimension (Size(XDONT)) :: IFMPTYT
14285 : Integer(kind = i4) :: ICRS
14286 : ! __________________________________________________________
14287 0 : Call UNIINV (XDONT, IWRKT)
14288 0 : IFMPTYT = .True.
14289 0 : NUNI = 0
14290 0 : Do ICRS = 1, Size(XDONT)
14291 0 : If (IFMPTYT(IWRKT(ICRS))) Then
14292 0 : IFMPTYT(IWRKT(ICRS)) = .False.
14293 0 : NUNI = NUNI + 1
14294 0 : XDONT (NUNI) = XDONT (ICRS)
14295 : End If
14296 : End Do
14297 0 : Return
14298 : !
14299 0 : End Subroutine D_unista
14300 :
14301 0 : Subroutine R_unista (XDONT, NUNI)
14302 : ! UNISTA = (Stable unique) Removes duplicates from an array,
14303 : ! leaving unique entries in the order of their first
14304 : ! appearance in the initial set.
14305 : ! Michel Olagnon - Feb. 2000
14306 : ! __________________________________________________________
14307 : ! _________________________________________________________
14308 : Real(kind = sp), Dimension (:), Intent (InOut) :: XDONT
14309 : Integer(kind = i4), Intent (Out) :: NUNI
14310 : ! __________________________________________________________
14311 : !
14312 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
14313 0 : Logical, Dimension (Size(XDONT)) :: IFMPTYT
14314 : Integer(kind = i4) :: ICRS
14315 : ! __________________________________________________________
14316 0 : Call UNIINV (XDONT, IWRKT)
14317 0 : IFMPTYT = .True.
14318 0 : NUNI = 0
14319 0 : Do ICRS = 1, Size(XDONT)
14320 0 : If (IFMPTYT(IWRKT(ICRS))) Then
14321 0 : IFMPTYT(IWRKT(ICRS)) = .False.
14322 0 : NUNI = NUNI + 1
14323 0 : XDONT (NUNI) = XDONT (ICRS)
14324 : End If
14325 : End Do
14326 0 : Return
14327 : !
14328 0 : End Subroutine R_unista
14329 :
14330 4 : Subroutine I_unista (XDONT, NUNI)
14331 : ! UNISTA = (Stable unique) Removes duplicates from an array,
14332 : ! leaving unique entries in the order of their first
14333 : ! appearance in the initial set.
14334 : ! Michel Olagnon - Feb. 2000
14335 : ! __________________________________________________________
14336 : ! __________________________________________________________
14337 : Integer(kind = i4), Dimension (:), Intent (InOut) :: XDONT
14338 : Integer(kind = i4), Intent (Out) :: NUNI
14339 : ! __________________________________________________________
14340 : !
14341 0 : Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
14342 4 : Logical, Dimension (Size(XDONT)) :: IFMPTYT
14343 : Integer(kind = i4) :: ICRS
14344 : ! __________________________________________________________
14345 4 : Call UNIINV (XDONT, IWRKT)
14346 40 : IFMPTYT = .True.
14347 4 : NUNI = 0
14348 40 : Do ICRS = 1, Size(XDONT)
14349 40 : If (IFMPTYT(IWRKT(ICRS))) Then
14350 12 : IFMPTYT(IWRKT(ICRS)) = .False.
14351 12 : NUNI = NUNI + 1
14352 12 : XDONT (NUNI) = XDONT (ICRS)
14353 : End If
14354 : End Do
14355 4 : Return
14356 : !
14357 0 : End Subroutine I_unista
14358 :
14359 0 : Recursive Function D_valmed (XDONT) Result (res_med)
14360 : ! Finds the median of XDONT using the recursive procedure
14361 : ! described in Knuth, The Art of Computer Programming,
14362 : ! vol. 3, 5.3.3 - This procedure is linear in time, and
14363 : ! does not require to be able to interpolate in the
14364 : ! set as the one used in INDNTH. It also has better worst
14365 : ! case behavior than INDNTH, but is about 30% slower in
14366 : ! average for random uniformly distributed values.
14367 : ! __________________________________________________________
14368 : ! __________________________________________________________
14369 : real(kind = dp), Dimension (:), Intent (In) :: XDONT
14370 : real(kind = dp) :: res_med
14371 : ! __________________________________________________________
14372 : real(kind = dp), Parameter :: XHUGE = HUGE (XDONT)
14373 0 : real(kind = dp), Dimension (SIZE(XDONT) + 6) :: XWRKT
14374 0 : real(kind = dp) :: XWRK, XWRK1, XMED7
14375 : !
14376 0 : Integer(kind = i4), Dimension ((SIZE(XDONT) + 6) / 7) :: ISTRT, IENDT, IMEDT
14377 : Integer(kind = i4) :: NDON, NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
14378 : Integer(kind = i4) :: IDEB, IWRK, IDCR, ICRS, ICRS1, ICRS2, IMED1
14379 : !
14380 0 : NDON = SIZE (XDONT)
14381 0 : NMED = (NDON + 1) / 2
14382 : ! write(unit=*,fmt=*) NMED, NDON
14383 : !
14384 : ! If the number of values is small, then use insertion sort
14385 : !
14386 0 : If (NDON < 35) Then
14387 : !
14388 : ! Bring minimum to first location to save test in decreasing loop
14389 : !
14390 0 : IDCR = NDON
14391 0 : If (XDONT (1) < XDONT (NDON)) Then
14392 0 : XWRK = XDONT (1)
14393 0 : XWRKT (IDCR) = XDONT (IDCR)
14394 : Else
14395 0 : XWRK = XDONT (IDCR)
14396 0 : XWRKT (IDCR) = XDONT (1)
14397 : end if
14398 0 : Do IWRK = 1, NDON - 2
14399 0 : IDCR = IDCR - 1
14400 0 : XWRK1 = XDONT (IDCR)
14401 0 : If (XWRK1 < XWRK) Then
14402 0 : XWRKT (IDCR) = XWRK
14403 0 : XWRK = XWRK1
14404 : Else
14405 0 : XWRKT (IDCR) = XWRK1
14406 : end if
14407 : End Do
14408 0 : XWRKT (1) = XWRK
14409 : !
14410 : ! Sort the first half, until we have NMED sorted values
14411 : !
14412 0 : Do ICRS = 3, NMED
14413 0 : XWRK = XWRKT (ICRS)
14414 0 : IDCR = ICRS - 1
14415 0 : Do
14416 0 : If (XWRK >= XWRKT(IDCR)) Exit
14417 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14418 0 : IDCR = IDCR - 1
14419 : End Do
14420 0 : XWRKT (IDCR + 1) = XWRK
14421 : End Do
14422 : !
14423 : ! Insert any value less than the current median in the first half
14424 : !
14425 0 : Do ICRS = NMED + 1, NDON
14426 0 : XWRK = XWRKT (ICRS)
14427 0 : If (XWRK < XWRKT (NMED)) Then
14428 0 : IDCR = NMED - 1
14429 0 : Do
14430 0 : If (XWRK >= XWRKT(IDCR)) Exit
14431 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14432 0 : IDCR = IDCR - 1
14433 : End Do
14434 0 : XWRKT (IDCR + 1) = XWRK
14435 : End If
14436 : End Do
14437 0 : res_med = XWRKT (NMED)
14438 0 : Return
14439 : End If
14440 : !
14441 : ! Make sorted subsets of 7 elements
14442 : ! This is done by a variant of insertion sort where a first
14443 : ! pass is used to bring the smallest element to the first position
14444 : ! decreasing disorder at the same time, so that we may remove
14445 : ! remove the loop test in the insertion loop.
14446 : !
14447 0 : DO IDEB = 1, NDON - 6, 7
14448 0 : IDCR = IDEB + 6
14449 0 : If (XDONT (IDEB) < XDONT (IDCR)) Then
14450 0 : XWRK = XDONT (IDEB)
14451 0 : XWRKT (IDCR) = XDONT (IDCR)
14452 : Else
14453 0 : XWRK = XDONT (IDCR)
14454 0 : XWRKT (IDCR) = XDONT (IDEB)
14455 : end if
14456 0 : Do IWRK = 1, 5
14457 0 : IDCR = IDCR - 1
14458 0 : XWRK1 = XDONT (IDCR)
14459 0 : If (XWRK1 < XWRK) Then
14460 0 : XWRKT (IDCR) = XWRK
14461 0 : XWRK = XWRK1
14462 : Else
14463 0 : XWRKT (IDCR) = XWRK1
14464 : end if
14465 : End Do
14466 0 : XWRKT (IDEB) = XWRK
14467 0 : Do ICRS = IDEB + 2, IDEB + 6
14468 0 : XWRK = XWRKT (ICRS)
14469 0 : If (XWRK < XWRKT(ICRS - 1)) Then
14470 0 : XWRKT (ICRS) = XWRKT (ICRS - 1)
14471 0 : IDCR = ICRS - 1
14472 0 : XWRK1 = XWRKT (IDCR - 1)
14473 0 : Do
14474 0 : If (XWRK >= XWRK1) Exit
14475 0 : XWRKT (IDCR) = XWRK1
14476 0 : IDCR = IDCR - 1
14477 0 : XWRK1 = XWRKT (IDCR - 1)
14478 : End Do
14479 0 : XWRKT (IDCR) = XWRK
14480 : end if
14481 : End Do
14482 : End Do
14483 : !
14484 : ! Add-up alternatively + and - HUGE values to make the number of data
14485 : ! an exact multiple of 7.
14486 : !
14487 0 : IDEB = 7 * (NDON / 7)
14488 0 : NTRI = NDON
14489 0 : If (IDEB < NDON) Then
14490 : !
14491 0 : XWRK1 = XHUGE
14492 0 : Do ICRS = IDEB + 1, IDEB + 7
14493 0 : If (ICRS <= NDON) Then
14494 0 : XWRKT (ICRS) = XDONT (ICRS)
14495 : Else
14496 0 : If (ne(XWRK1, XHUGE)) NMED = NMED + 1
14497 0 : XWRKT (ICRS) = XWRK1
14498 0 : XWRK1 = - XWRK1
14499 : end if
14500 : End Do
14501 : !
14502 0 : Do ICRS = IDEB + 2, IDEB + 7
14503 0 : XWRK = XWRKT (ICRS)
14504 0 : Do IDCR = ICRS - 1, IDEB + 1, - 1
14505 0 : If (XWRK >= XWRKT(IDCR)) Exit
14506 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14507 : End Do
14508 0 : XWRKT (IDCR + 1) = XWRK
14509 : End Do
14510 : !
14511 : NTRI = IDEB + 7
14512 : End If
14513 : !
14514 : ! Make the set of the indices of median values of each sorted subset
14515 : !
14516 0 : IDON1 = 0
14517 0 : Do IDON = 1, NTRI, 7
14518 0 : IDON1 = IDON1 + 1
14519 0 : IMEDT (IDON1) = IDON + 3
14520 : End Do
14521 : !
14522 : ! Find XMED7, the median of the medians
14523 : !
14524 0 : XMED7 = D_valmed (XWRKT (IMEDT))
14525 : !
14526 : ! Count how many values are not higher than (and how many equal to) XMED7
14527 : ! This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
14528 : ! subsets where the median is lower than the median of medians. For similar
14529 : ! reasons, we also have at least 2N/7 values not lower than XMED7. At the
14530 : ! same time, we find in each subset the index of the last value < XMED7,
14531 : ! and that of the first > XMED7. These indices will be used to restrict the
14532 : ! search for the median as the Kth element in the subset (> or <) where
14533 : ! we know it to be.
14534 : !
14535 0 : IDON1 = 1
14536 0 : NLEQ = 0
14537 0 : NEQU = 0
14538 0 : Do IDON = 1, NTRI, 7
14539 0 : IMED = IDON + 3
14540 0 : If (XWRKT (IMED) > XMED7) Then
14541 0 : IMED = IMED - 2
14542 0 : If (XWRKT (IMED) > XMED7) Then
14543 : IMED = IMED - 1
14544 0 : Else If (XWRKT (IMED) < XMED7) Then
14545 0 : IMED = IMED + 1
14546 : end if
14547 0 : Else If (XWRKT (IMED) < XMED7) Then
14548 0 : IMED = IMED + 2
14549 0 : If (XWRKT (IMED) > XMED7) Then
14550 0 : IMED = IMED - 1
14551 0 : Else If (XWRKT (IMED) < XMED7) Then
14552 0 : IMED = IMED + 1
14553 : end if
14554 : end if
14555 0 : If (XWRKT (IMED) > XMED7) Then
14556 0 : NLEQ = NLEQ + IMED - IDON
14557 0 : IENDT (IDON1) = IMED - 1
14558 0 : ISTRT (IDON1) = IMED
14559 0 : Else If (XWRKT (IMED) < XMED7) Then
14560 0 : NLEQ = NLEQ + IMED - IDON + 1
14561 0 : IENDT (IDON1) = IMED
14562 0 : ISTRT (IDON1) = IMED + 1
14563 : Else ! If (XWRKT (IMED) == XMED7)
14564 0 : NLEQ = NLEQ + IMED - IDON + 1
14565 0 : NEQU = NEQU + 1
14566 0 : IENDT (IDON1) = IMED - 1
14567 0 : Do IMED1 = IMED - 1, IDON, -1
14568 0 : If (eq(XWRKT (IMED1), XMED7)) Then
14569 0 : NEQU = NEQU + 1
14570 0 : IENDT (IDON1) = IMED1 - 1
14571 : Else
14572 : Exit
14573 : End If
14574 : End Do
14575 0 : ISTRT (IDON1) = IMED + 1
14576 0 : Do IMED1 = IMED + 1, IDON + 6
14577 0 : If (eq(XWRKT (IMED1), XMED7)) Then
14578 0 : NEQU = NEQU + 1
14579 0 : NLEQ = NLEQ + 1
14580 0 : ISTRT (IDON1) = IMED1 + 1
14581 : Else
14582 : Exit
14583 : End If
14584 : End Do
14585 : end if
14586 0 : IDON1 = IDON1 + 1
14587 : End Do
14588 : !
14589 : ! Carry out a partial insertion sort to find the Kth smallest of the
14590 : ! large values, or the Kth largest of the small values, according to
14591 : ! what is needed.
14592 : !
14593 0 : If (NLEQ - NEQU + 1 <= NMED) Then
14594 0 : If (NLEQ < NMED) Then ! Not enough low values
14595 0 : XWRK1 = XHUGE
14596 0 : NORD = NMED - NLEQ
14597 0 : IDON1 = 0
14598 0 : ICRS1 = 1
14599 0 : ICRS2 = 0
14600 0 : IDCR = 0
14601 0 : Do IDON = 1, NTRI, 7
14602 0 : IDON1 = IDON1 + 1
14603 0 : If (ICRS2 < NORD) Then
14604 0 : Do ICRS = ISTRT (IDON1), IDON + 6
14605 0 : If (XWRKT(ICRS) < XWRK1) Then
14606 0 : XWRK = XWRKT (ICRS)
14607 0 : Do IDCR = ICRS1 - 1, 1, - 1
14608 0 : If (XWRK >= XWRKT(IDCR)) Exit
14609 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14610 : End Do
14611 0 : XWRKT (IDCR + 1) = XWRK
14612 0 : XWRK1 = XWRKT(ICRS1)
14613 : Else
14614 0 : If (ICRS2 < NORD) Then
14615 0 : XWRKT (ICRS1) = XWRKT (ICRS)
14616 0 : XWRK1 = XWRKT(ICRS1)
14617 : end if
14618 : End If
14619 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
14620 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
14621 : End Do
14622 : Else
14623 0 : Do ICRS = ISTRT (IDON1), IDON + 6
14624 0 : If (XWRKT(ICRS) >= XWRK1) Exit
14625 0 : XWRK = XWRKT (ICRS)
14626 0 : Do IDCR = ICRS1 - 1, 1, - 1
14627 0 : If (XWRK >= XWRKT(IDCR)) Exit
14628 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14629 : End Do
14630 0 : XWRKT (IDCR + 1) = XWRK
14631 0 : XWRK1 = XWRKT(ICRS1)
14632 : End Do
14633 : End If
14634 : End Do
14635 0 : res_med = XWRK1
14636 0 : Return
14637 : Else
14638 0 : res_med = XMED7
14639 0 : Return
14640 : End If
14641 : Else ! If (NLEQ > NMED)
14642 : ! Not enough high values
14643 0 : XWRK1 = -XHUGE
14644 0 : NORD = NLEQ - NEQU - NMED + 1
14645 0 : IDON1 = 0
14646 0 : ICRS1 = 1
14647 0 : ICRS2 = 0
14648 0 : Do IDON = 1, NTRI, 7
14649 0 : IDON1 = IDON1 + 1
14650 0 : If (ICRS2 < NORD) Then
14651 : !
14652 0 : Do ICRS = IDON, IENDT (IDON1)
14653 0 : If (XWRKT(ICRS) > XWRK1) Then
14654 0 : XWRK = XWRKT (ICRS)
14655 0 : IDCR = ICRS1 - 1
14656 0 : Do IDCR = ICRS1 - 1, 1, - 1
14657 0 : If (XWRK <= XWRKT(IDCR)) Exit
14658 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14659 : End Do
14660 0 : XWRKT (IDCR + 1) = XWRK
14661 0 : XWRK1 = XWRKT(ICRS1)
14662 : Else
14663 0 : If (ICRS2 < NORD) Then
14664 0 : XWRKT (ICRS1) = XWRKT (ICRS)
14665 0 : XWRK1 = XWRKT (ICRS1)
14666 : End If
14667 : End If
14668 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
14669 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
14670 : End Do
14671 : Else
14672 0 : Do ICRS = IENDT (IDON1), IDON, -1
14673 0 : If (XWRKT(ICRS) > XWRK1) Then
14674 0 : XWRK = XWRKT (ICRS)
14675 0 : IDCR = ICRS1 - 1
14676 0 : Do IDCR = ICRS1 - 1, 1, - 1
14677 0 : If (XWRK <= XWRKT(IDCR)) Exit
14678 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14679 : End Do
14680 0 : XWRKT (IDCR + 1) = XWRK
14681 0 : XWRK1 = XWRKT(ICRS1)
14682 : Else
14683 : Exit
14684 : End If
14685 : End Do
14686 : end if
14687 : End Do
14688 : !
14689 0 : res_med = XWRK1
14690 0 : Return
14691 : End If
14692 : !
14693 4 : End Function D_valmed
14694 :
14695 0 : Recursive Function R_valmed (XDONT) Result (res_med)
14696 : ! Finds the median of XDONT using the recursive procedure
14697 : ! described in Knuth, The Art of Computer Programming,
14698 : ! vol. 3, 5.3.3 - This procedure is linear in time, and
14699 : ! does not require to be able to interpolate in the
14700 : ! set as the one used in INDNTH. It also has better worst
14701 : ! case behavior than INDNTH, but is about 30% slower in
14702 : ! average for random uniformly distributed values.
14703 : ! __________________________________________________________
14704 : ! _________________________________________________________
14705 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
14706 : Real(kind = sp) :: res_med
14707 : ! __________________________________________________________
14708 : Real(kind = sp), Parameter :: XHUGE = HUGE (XDONT)
14709 0 : Real(kind = sp), Dimension (SIZE(XDONT) + 6) :: XWRKT
14710 0 : Real(kind = sp) :: XWRK, XWRK1, XMED7
14711 : !
14712 0 : Integer(kind = i4), Dimension ((SIZE(XDONT) + 6) / 7) :: ISTRT, IENDT, IMEDT
14713 : Integer(kind = i4) :: NDON, NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
14714 : Integer(kind = i4) :: IDEB, IWRK, IDCR, ICRS, ICRS1, ICRS2, IMED1
14715 : !
14716 0 : NDON = SIZE (XDONT)
14717 0 : NMED = (NDON + 1) / 2
14718 : ! write(unit=*,fmt=*) NMED, NDON
14719 : !
14720 : ! If the number of values is small, then use insertion sort
14721 : !
14722 0 : If (NDON < 35) Then
14723 : !
14724 : ! Bring minimum to first location to save test in decreasing loop
14725 : !
14726 0 : IDCR = NDON
14727 0 : If (XDONT (1) < XDONT (NDON)) Then
14728 0 : XWRK = XDONT (1)
14729 0 : XWRKT (IDCR) = XDONT (IDCR)
14730 : Else
14731 0 : XWRK = XDONT (IDCR)
14732 0 : XWRKT (IDCR) = XDONT (1)
14733 : end if
14734 0 : Do IWRK = 1, NDON - 2
14735 0 : IDCR = IDCR - 1
14736 0 : XWRK1 = XDONT (IDCR)
14737 0 : If (XWRK1 < XWRK) Then
14738 0 : XWRKT (IDCR) = XWRK
14739 0 : XWRK = XWRK1
14740 : Else
14741 0 : XWRKT (IDCR) = XWRK1
14742 : end if
14743 : End Do
14744 0 : XWRKT (1) = XWRK
14745 : !
14746 : ! Sort the first half, until we have NMED sorted values
14747 : !
14748 0 : Do ICRS = 3, NMED
14749 0 : XWRK = XWRKT (ICRS)
14750 0 : IDCR = ICRS - 1
14751 0 : Do
14752 0 : If (XWRK >= XWRKT(IDCR)) Exit
14753 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14754 0 : IDCR = IDCR - 1
14755 : End Do
14756 0 : XWRKT (IDCR + 1) = XWRK
14757 : End Do
14758 : !
14759 : ! Insert any value less than the current median in the first half
14760 : !
14761 0 : Do ICRS = NMED + 1, NDON
14762 0 : XWRK = XWRKT (ICRS)
14763 0 : If (XWRK < XWRKT (NMED)) Then
14764 0 : IDCR = NMED - 1
14765 0 : Do
14766 0 : If (XWRK >= XWRKT(IDCR)) Exit
14767 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14768 0 : IDCR = IDCR - 1
14769 : End Do
14770 0 : XWRKT (IDCR + 1) = XWRK
14771 : End If
14772 : End Do
14773 0 : res_med = XWRKT (NMED)
14774 0 : Return
14775 : End If
14776 : !
14777 : ! Make sorted subsets of 7 elements
14778 : ! This is done by a variant of insertion sort where a first
14779 : ! pass is used to bring the smallest element to the first position
14780 : ! decreasing disorder at the same time, so that we may remove
14781 : ! remove the loop test in the insertion loop.
14782 : !
14783 0 : DO IDEB = 1, NDON - 6, 7
14784 0 : IDCR = IDEB + 6
14785 0 : If (XDONT (IDEB) < XDONT (IDCR)) Then
14786 0 : XWRK = XDONT (IDEB)
14787 0 : XWRKT (IDCR) = XDONT (IDCR)
14788 : Else
14789 0 : XWRK = XDONT (IDCR)
14790 0 : XWRKT (IDCR) = XDONT (IDEB)
14791 : end if
14792 0 : Do IWRK = 1, 5
14793 0 : IDCR = IDCR - 1
14794 0 : XWRK1 = XDONT (IDCR)
14795 0 : If (XWRK1 < XWRK) Then
14796 0 : XWRKT (IDCR) = XWRK
14797 0 : XWRK = XWRK1
14798 : Else
14799 0 : XWRKT (IDCR) = XWRK1
14800 : end if
14801 : End Do
14802 0 : XWRKT (IDEB) = XWRK
14803 0 : Do ICRS = IDEB + 2, IDEB + 6
14804 0 : XWRK = XWRKT (ICRS)
14805 0 : If (XWRK < XWRKT(ICRS - 1)) Then
14806 0 : XWRKT (ICRS) = XWRKT (ICRS - 1)
14807 0 : IDCR = ICRS - 1
14808 0 : XWRK1 = XWRKT (IDCR - 1)
14809 0 : Do
14810 0 : If (XWRK >= XWRK1) Exit
14811 0 : XWRKT (IDCR) = XWRK1
14812 0 : IDCR = IDCR - 1
14813 0 : XWRK1 = XWRKT (IDCR - 1)
14814 : End Do
14815 0 : XWRKT (IDCR) = XWRK
14816 : end if
14817 : End Do
14818 : End Do
14819 : !
14820 : ! Add-up alternatively + and - HUGE values to make the number of data
14821 : ! an exact multiple of 7.
14822 : !
14823 0 : IDEB = 7 * (NDON / 7)
14824 0 : NTRI = NDON
14825 0 : If (IDEB < NDON) Then
14826 : !
14827 0 : XWRK1 = XHUGE
14828 0 : Do ICRS = IDEB + 1, IDEB + 7
14829 0 : If (ICRS <= NDON) Then
14830 0 : XWRKT (ICRS) = XDONT (ICRS)
14831 : Else
14832 0 : If (ne(XWRK1, XHUGE)) NMED = NMED + 1
14833 0 : XWRKT (ICRS) = XWRK1
14834 0 : XWRK1 = - XWRK1
14835 : end if
14836 : End Do
14837 : !
14838 0 : Do ICRS = IDEB + 2, IDEB + 7
14839 0 : XWRK = XWRKT (ICRS)
14840 0 : Do IDCR = ICRS - 1, IDEB + 1, - 1
14841 0 : If (XWRK >= XWRKT(IDCR)) Exit
14842 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14843 : End Do
14844 0 : XWRKT (IDCR + 1) = XWRK
14845 : End Do
14846 : !
14847 : NTRI = IDEB + 7
14848 : End If
14849 : !
14850 : ! Make the set of the indices of median values of each sorted subset
14851 : !
14852 0 : IDON1 = 0
14853 0 : Do IDON = 1, NTRI, 7
14854 0 : IDON1 = IDON1 + 1
14855 0 : IMEDT (IDON1) = IDON + 3
14856 : End Do
14857 : !
14858 : ! Find XMED7, the median of the medians
14859 : !
14860 0 : XMED7 = R_valmed (XWRKT (IMEDT))
14861 : !
14862 : ! Count how many values are not higher than (and how many equal to) XMED7
14863 : ! This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
14864 : ! subsets where the median is lower than the median of medians. For similar
14865 : ! reasons, we also have at least 2N/7 values not lower than XMED7. At the
14866 : ! same time, we find in each subset the index of the last value < XMED7,
14867 : ! and that of the first > XMED7. These indices will be used to restrict the
14868 : ! search for the median as the Kth element in the subset (> or <) where
14869 : ! we know it to be.
14870 : !
14871 0 : IDON1 = 1
14872 0 : NLEQ = 0
14873 0 : NEQU = 0
14874 0 : Do IDON = 1, NTRI, 7
14875 0 : IMED = IDON + 3
14876 0 : If (XWRKT (IMED) > XMED7) Then
14877 0 : IMED = IMED - 2
14878 0 : If (XWRKT (IMED) > XMED7) Then
14879 : IMED = IMED - 1
14880 0 : Else If (XWRKT (IMED) < XMED7) Then
14881 0 : IMED = IMED + 1
14882 : end if
14883 0 : Else If (XWRKT (IMED) < XMED7) Then
14884 0 : IMED = IMED + 2
14885 0 : If (XWRKT (IMED) > XMED7) Then
14886 0 : IMED = IMED - 1
14887 0 : Else If (XWRKT (IMED) < XMED7) Then
14888 0 : IMED = IMED + 1
14889 : end if
14890 : end if
14891 0 : If (XWRKT (IMED) > XMED7) Then
14892 0 : NLEQ = NLEQ + IMED - IDON
14893 0 : IENDT (IDON1) = IMED - 1
14894 0 : ISTRT (IDON1) = IMED
14895 0 : Else If (XWRKT (IMED) < XMED7) Then
14896 0 : NLEQ = NLEQ + IMED - IDON + 1
14897 0 : IENDT (IDON1) = IMED
14898 0 : ISTRT (IDON1) = IMED + 1
14899 : Else ! If (XWRKT (IMED) == XMED7)
14900 0 : NLEQ = NLEQ + IMED - IDON + 1
14901 0 : NEQU = NEQU + 1
14902 0 : IENDT (IDON1) = IMED - 1
14903 0 : Do IMED1 = IMED - 1, IDON, -1
14904 0 : If (eq(XWRKT (IMED1), XMED7)) Then
14905 0 : NEQU = NEQU + 1
14906 0 : IENDT (IDON1) = IMED1 - 1
14907 : Else
14908 : Exit
14909 : End If
14910 : End Do
14911 0 : ISTRT (IDON1) = IMED + 1
14912 0 : Do IMED1 = IMED + 1, IDON + 6
14913 0 : If (eq(XWRKT (IMED1), XMED7)) Then
14914 0 : NEQU = NEQU + 1
14915 0 : NLEQ = NLEQ + 1
14916 0 : ISTRT (IDON1) = IMED1 + 1
14917 : Else
14918 : Exit
14919 : End If
14920 : End Do
14921 : end if
14922 0 : IDON1 = IDON1 + 1
14923 : End Do
14924 : !
14925 : ! Carry out a partial insertion sort to find the Kth smallest of the
14926 : ! large values, or the Kth largest of the small values, according to
14927 : ! what is needed.
14928 : !
14929 0 : If (NLEQ - NEQU + 1 <= NMED) Then
14930 0 : If (NLEQ < NMED) Then ! Not enough low values
14931 0 : XWRK1 = XHUGE
14932 0 : NORD = NMED - NLEQ
14933 0 : IDON1 = 0
14934 0 : ICRS1 = 1
14935 0 : ICRS2 = 0
14936 0 : IDCR = 0
14937 0 : Do IDON = 1, NTRI, 7
14938 0 : IDON1 = IDON1 + 1
14939 0 : If (ICRS2 < NORD) Then
14940 0 : Do ICRS = ISTRT (IDON1), IDON + 6
14941 0 : If (XWRKT(ICRS) < XWRK1) Then
14942 0 : XWRK = XWRKT (ICRS)
14943 0 : Do IDCR = ICRS1 - 1, 1, - 1
14944 0 : If (XWRK >= XWRKT(IDCR)) Exit
14945 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14946 : End Do
14947 0 : XWRKT (IDCR + 1) = XWRK
14948 0 : XWRK1 = XWRKT(ICRS1)
14949 : Else
14950 0 : If (ICRS2 < NORD) Then
14951 0 : XWRKT (ICRS1) = XWRKT (ICRS)
14952 0 : XWRK1 = XWRKT(ICRS1)
14953 : end if
14954 : End If
14955 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
14956 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
14957 : End Do
14958 : Else
14959 0 : Do ICRS = ISTRT (IDON1), IDON + 6
14960 0 : If (XWRKT(ICRS) >= XWRK1) Exit
14961 0 : XWRK = XWRKT (ICRS)
14962 0 : Do IDCR = ICRS1 - 1, 1, - 1
14963 0 : If (XWRK >= XWRKT(IDCR)) Exit
14964 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14965 : End Do
14966 0 : XWRKT (IDCR + 1) = XWRK
14967 0 : XWRK1 = XWRKT(ICRS1)
14968 : End Do
14969 : End If
14970 : End Do
14971 0 : res_med = XWRK1
14972 0 : Return
14973 : Else
14974 0 : res_med = XMED7
14975 0 : Return
14976 : End If
14977 : Else ! If (NLEQ > NMED)
14978 : ! Not enough high values
14979 0 : XWRK1 = -XHUGE
14980 0 : NORD = NLEQ - NEQU - NMED + 1
14981 0 : IDON1 = 0
14982 0 : ICRS1 = 1
14983 0 : ICRS2 = 0
14984 0 : Do IDON = 1, NTRI, 7
14985 0 : IDON1 = IDON1 + 1
14986 0 : If (ICRS2 < NORD) Then
14987 : !
14988 0 : Do ICRS = IDON, IENDT (IDON1)
14989 0 : If (XWRKT(ICRS) > XWRK1) Then
14990 0 : XWRK = XWRKT (ICRS)
14991 0 : IDCR = ICRS1 - 1
14992 0 : Do IDCR = ICRS1 - 1, 1, - 1
14993 0 : If (XWRK <= XWRKT(IDCR)) Exit
14994 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
14995 : End Do
14996 0 : XWRKT (IDCR + 1) = XWRK
14997 0 : XWRK1 = XWRKT(ICRS1)
14998 : Else
14999 0 : If (ICRS2 < NORD) Then
15000 0 : XWRKT (ICRS1) = XWRKT (ICRS)
15001 0 : XWRK1 = XWRKT (ICRS1)
15002 : End If
15003 : End If
15004 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
15005 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
15006 : End Do
15007 : Else
15008 0 : Do ICRS = IENDT (IDON1), IDON, -1
15009 0 : If (XWRKT(ICRS) > XWRK1) Then
15010 0 : XWRK = XWRKT (ICRS)
15011 0 : IDCR = ICRS1 - 1
15012 0 : Do IDCR = ICRS1 - 1, 1, - 1
15013 0 : If (XWRK <= XWRKT(IDCR)) Exit
15014 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
15015 : End Do
15016 0 : XWRKT (IDCR + 1) = XWRK
15017 0 : XWRK1 = XWRKT(ICRS1)
15018 : Else
15019 : Exit
15020 : End If
15021 : End Do
15022 : end if
15023 : End Do
15024 : !
15025 0 : res_med = XWRK1
15026 0 : Return
15027 : End If
15028 : !
15029 : End Function R_valmed
15030 :
15031 0 : Recursive Function I_valmed (XDONT) Result (res_med)
15032 : ! Finds the median of XDONT using the recursive procedure
15033 : ! described in Knuth, The Art of Computer Programming,
15034 : ! vol. 3, 5.3.3 - This procedure is linear in time, and
15035 : ! does not require to be able to interpolate in the
15036 : ! set as the one used in INDNTH. It also has better worst
15037 : ! case behavior than INDNTH, but is about 30% slower in
15038 : ! average for random uniformly distributed values.
15039 : ! __________________________________________________________
15040 : ! __________________________________________________________
15041 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
15042 : Integer(kind = i4) :: res_med
15043 : ! __________________________________________________________
15044 : Integer(kind = i4), Parameter :: XHUGE = HUGE (XDONT)
15045 0 : Integer(kind = i4), Dimension (SIZE(XDONT) + 6) :: XWRKT
15046 : Integer(kind = i4) :: XWRK, XWRK1, XMED7
15047 : !
15048 0 : Integer(kind = i4), Dimension ((SIZE(XDONT) + 6) / 7) :: ISTRT, IENDT, IMEDT
15049 : Integer(kind = i4) :: NDON, NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
15050 : Integer(kind = i4) :: IDEB, IWRK, IDCR, ICRS, ICRS1, ICRS2, IMED1
15051 : !
15052 0 : NDON = SIZE (XDONT)
15053 0 : NMED = (NDON + 1) / 2
15054 : ! write(unit=*,fmt=*) NMED, NDON
15055 : !
15056 : ! If the number of values is small, then use insertion sort
15057 : !
15058 0 : If (NDON < 35) Then
15059 : !
15060 : ! Bring minimum to first location to save test in decreasing loop
15061 : !
15062 0 : IDCR = NDON
15063 0 : If (XDONT (1) < XDONT (NDON)) Then
15064 0 : XWRK = XDONT (1)
15065 0 : XWRKT (IDCR) = XDONT (IDCR)
15066 : Else
15067 0 : XWRK = XDONT (IDCR)
15068 0 : XWRKT (IDCR) = XDONT (1)
15069 : end if
15070 0 : Do IWRK = 1, NDON - 2
15071 0 : IDCR = IDCR - 1
15072 0 : XWRK1 = XDONT (IDCR)
15073 0 : If (XWRK1 < XWRK) Then
15074 0 : XWRKT (IDCR) = XWRK
15075 0 : XWRK = XWRK1
15076 : Else
15077 0 : XWRKT (IDCR) = XWRK1
15078 : end if
15079 : End Do
15080 0 : XWRKT (1) = XWRK
15081 : !
15082 : ! Sort the first half, until we have NMED sorted values
15083 : !
15084 0 : Do ICRS = 3, NMED
15085 0 : XWRK = XWRKT (ICRS)
15086 0 : IDCR = ICRS - 1
15087 0 : Do
15088 0 : If (XWRK >= XWRKT(IDCR)) Exit
15089 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
15090 0 : IDCR = IDCR - 1
15091 : End Do
15092 0 : XWRKT (IDCR + 1) = XWRK
15093 : End Do
15094 : !
15095 : ! Insert any value less than the current median in the first half
15096 : !
15097 0 : Do ICRS = NMED + 1, NDON
15098 0 : XWRK = XWRKT (ICRS)
15099 0 : If (XWRK < XWRKT (NMED)) Then
15100 0 : IDCR = NMED - 1
15101 0 : Do
15102 0 : If (XWRK >= XWRKT(IDCR)) Exit
15103 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
15104 0 : IDCR = IDCR - 1
15105 : End Do
15106 0 : XWRKT (IDCR + 1) = XWRK
15107 : End If
15108 : End Do
15109 0 : res_med = XWRKT (NMED)
15110 0 : Return
15111 : End If
15112 : !
15113 : ! Make sorted subsets of 7 elements
15114 : ! This is done by a variant of insertion sort where a first
15115 : ! pass is used to bring the smallest element to the first position
15116 : ! decreasing disorder at the same time, so that we may remove
15117 : ! remove the loop test in the insertion loop.
15118 : !
15119 0 : DO IDEB = 1, NDON - 6, 7
15120 0 : IDCR = IDEB + 6
15121 0 : If (XDONT (IDEB) < XDONT (IDCR)) Then
15122 0 : XWRK = XDONT (IDEB)
15123 0 : XWRKT (IDCR) = XDONT (IDCR)
15124 : Else
15125 0 : XWRK = XDONT (IDCR)
15126 0 : XWRKT (IDCR) = XDONT (IDEB)
15127 : end if
15128 0 : Do IWRK = 1, 5
15129 0 : IDCR = IDCR - 1
15130 0 : XWRK1 = XDONT (IDCR)
15131 0 : If (XWRK1 < XWRK) Then
15132 0 : XWRKT (IDCR) = XWRK
15133 0 : XWRK = XWRK1
15134 : Else
15135 0 : XWRKT (IDCR) = XWRK1
15136 : end if
15137 : End Do
15138 0 : XWRKT (IDEB) = XWRK
15139 0 : Do ICRS = IDEB + 2, IDEB + 6
15140 0 : XWRK = XWRKT (ICRS)
15141 0 : If (XWRK < XWRKT(ICRS - 1)) Then
15142 0 : XWRKT (ICRS) = XWRKT (ICRS - 1)
15143 0 : IDCR = ICRS - 1
15144 0 : XWRK1 = XWRKT (IDCR - 1)
15145 0 : Do
15146 0 : If (XWRK >= XWRK1) Exit
15147 0 : XWRKT (IDCR) = XWRK1
15148 0 : IDCR = IDCR - 1
15149 0 : XWRK1 = XWRKT (IDCR - 1)
15150 : End Do
15151 0 : XWRKT (IDCR) = XWRK
15152 : end if
15153 : End Do
15154 : End Do
15155 : !
15156 : ! Add-up alternatively + and - HUGE values to make the number of data
15157 : ! an exact multiple of 7.
15158 : !
15159 0 : IDEB = 7 * (NDON / 7)
15160 0 : NTRI = NDON
15161 0 : If (IDEB < NDON) Then
15162 : !
15163 0 : XWRK1 = XHUGE
15164 0 : Do ICRS = IDEB + 1, IDEB + 7
15165 0 : If (ICRS <= NDON) Then
15166 0 : XWRKT (ICRS) = XDONT (ICRS)
15167 : Else
15168 0 : If (XWRK1 /= XHUGE) NMED = NMED + 1
15169 0 : XWRKT (ICRS) = XWRK1
15170 0 : XWRK1 = - XWRK1
15171 : end if
15172 : End Do
15173 : !
15174 0 : Do ICRS = IDEB + 2, IDEB + 7
15175 0 : XWRK = XWRKT (ICRS)
15176 0 : Do IDCR = ICRS - 1, IDEB + 1, - 1
15177 0 : If (XWRK >= XWRKT(IDCR)) Exit
15178 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
15179 : End Do
15180 0 : XWRKT (IDCR + 1) = XWRK
15181 : End Do
15182 : !
15183 : NTRI = IDEB + 7
15184 : End If
15185 : !
15186 : ! Make the set of the indices of median values of each sorted subset
15187 : !
15188 0 : IDON1 = 0
15189 0 : Do IDON = 1, NTRI, 7
15190 0 : IDON1 = IDON1 + 1
15191 0 : IMEDT (IDON1) = IDON + 3
15192 : End Do
15193 : !
15194 : ! Find XMED7, the median of the medians
15195 : !
15196 0 : XMED7 = I_valmed (XWRKT (IMEDT))
15197 : !
15198 : ! Count how many values are not higher than (and how many equal to) XMED7
15199 : ! This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
15200 : ! subsets where the median is lower than the median of medians. For similar
15201 : ! reasons, we also have at least 2N/7 values not lower than XMED7. At the
15202 : ! same time, we find in each subset the index of the last value < XMED7,
15203 : ! and that of the first > XMED7. These indices will be used to restrict the
15204 : ! search for the median as the Kth element in the subset (> or <) where
15205 : ! we know it to be.
15206 : !
15207 0 : IDON1 = 1
15208 0 : NLEQ = 0
15209 0 : NEQU = 0
15210 0 : Do IDON = 1, NTRI, 7
15211 0 : IMED = IDON + 3
15212 0 : If (XWRKT (IMED) > XMED7) Then
15213 0 : IMED = IMED - 2
15214 0 : If (XWRKT (IMED) > XMED7) Then
15215 : IMED = IMED - 1
15216 0 : Else If (XWRKT (IMED) < XMED7) Then
15217 0 : IMED = IMED + 1
15218 : end if
15219 0 : Else If (XWRKT (IMED) < XMED7) Then
15220 0 : IMED = IMED + 2
15221 0 : If (XWRKT (IMED) > XMED7) Then
15222 0 : IMED = IMED - 1
15223 0 : Else If (XWRKT (IMED) < XMED7) Then
15224 0 : IMED = IMED + 1
15225 : end if
15226 : end if
15227 0 : If (XWRKT (IMED) > XMED7) Then
15228 0 : NLEQ = NLEQ + IMED - IDON
15229 0 : IENDT (IDON1) = IMED - 1
15230 0 : ISTRT (IDON1) = IMED
15231 0 : Else If (XWRKT (IMED) < XMED7) Then
15232 0 : NLEQ = NLEQ + IMED - IDON + 1
15233 0 : IENDT (IDON1) = IMED
15234 0 : ISTRT (IDON1) = IMED + 1
15235 : Else ! If (XWRKT (IMED) == XMED7)
15236 0 : NLEQ = NLEQ + IMED - IDON + 1
15237 0 : NEQU = NEQU + 1
15238 0 : IENDT (IDON1) = IMED - 1
15239 0 : Do IMED1 = IMED - 1, IDON, -1
15240 0 : If (XWRKT (IMED1) == XMED7) Then
15241 0 : NEQU = NEQU + 1
15242 0 : IENDT (IDON1) = IMED1 - 1
15243 : Else
15244 : Exit
15245 : End If
15246 : End Do
15247 0 : ISTRT (IDON1) = IMED + 1
15248 0 : Do IMED1 = IMED + 1, IDON + 6
15249 0 : If (XWRKT (IMED1) == XMED7) Then
15250 0 : NEQU = NEQU + 1
15251 0 : NLEQ = NLEQ + 1
15252 0 : ISTRT (IDON1) = IMED1 + 1
15253 : Else
15254 : Exit
15255 : End If
15256 : End Do
15257 : end if
15258 0 : IDON1 = IDON1 + 1
15259 : End Do
15260 : !
15261 : ! Carry out a partial insertion sort to find the Kth smallest of the
15262 : ! large values, or the Kth largest of the small values, according to
15263 : ! what is needed.
15264 : !
15265 0 : If (NLEQ - NEQU + 1 <= NMED) Then
15266 0 : If (NLEQ < NMED) Then ! Not enough low values
15267 0 : XWRK1 = XHUGE
15268 0 : NORD = NMED - NLEQ
15269 0 : IDON1 = 0
15270 0 : ICRS1 = 1
15271 0 : ICRS2 = 0
15272 0 : IDCR = 0
15273 0 : Do IDON = 1, NTRI, 7
15274 0 : IDON1 = IDON1 + 1
15275 0 : If (ICRS2 < NORD) Then
15276 0 : Do ICRS = ISTRT (IDON1), IDON + 6
15277 0 : If (XWRKT(ICRS) < XWRK1) Then
15278 0 : XWRK = XWRKT (ICRS)
15279 0 : Do IDCR = ICRS1 - 1, 1, - 1
15280 0 : If (XWRK >= XWRKT(IDCR)) Exit
15281 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
15282 : End Do
15283 0 : XWRKT (IDCR + 1) = XWRK
15284 0 : XWRK1 = XWRKT(ICRS1)
15285 : Else
15286 0 : If (ICRS2 < NORD) Then
15287 0 : XWRKT (ICRS1) = XWRKT (ICRS)
15288 : XWRK1 = XWRKT(ICRS1)
15289 : end if
15290 : End If
15291 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
15292 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
15293 : End Do
15294 : Else
15295 0 : Do ICRS = ISTRT (IDON1), IDON + 6
15296 0 : If (XWRKT(ICRS) >= XWRK1) Exit
15297 0 : XWRK = XWRKT (ICRS)
15298 0 : Do IDCR = ICRS1 - 1, 1, - 1
15299 0 : If (XWRK >= XWRKT(IDCR)) Exit
15300 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
15301 : End Do
15302 0 : XWRKT (IDCR + 1) = XWRK
15303 0 : XWRK1 = XWRKT(ICRS1)
15304 : End Do
15305 : End If
15306 : End Do
15307 0 : res_med = XWRK1
15308 0 : Return
15309 : Else
15310 0 : res_med = XMED7
15311 : Return
15312 : End If
15313 : Else ! If (NLEQ > NMED)
15314 : ! Not enough high values
15315 0 : XWRK1 = -XHUGE
15316 0 : NORD = NLEQ - NEQU - NMED + 1
15317 0 : IDON1 = 0
15318 0 : ICRS1 = 1
15319 0 : ICRS2 = 0
15320 0 : Do IDON = 1, NTRI, 7
15321 0 : IDON1 = IDON1 + 1
15322 0 : If (ICRS2 < NORD) Then
15323 : !
15324 0 : Do ICRS = IDON, IENDT (IDON1)
15325 0 : If (XWRKT(ICRS) > XWRK1) Then
15326 0 : XWRK = XWRKT (ICRS)
15327 0 : IDCR = ICRS1 - 1
15328 0 : Do IDCR = ICRS1 - 1, 1, - 1
15329 0 : If (XWRK <= XWRKT(IDCR)) Exit
15330 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
15331 : End Do
15332 0 : XWRKT (IDCR + 1) = XWRK
15333 0 : XWRK1 = XWRKT(ICRS1)
15334 : Else
15335 0 : If (ICRS2 < NORD) Then
15336 0 : XWRKT (ICRS1) = XWRKT (ICRS)
15337 : XWRK1 = XWRKT (ICRS1)
15338 : End If
15339 : End If
15340 0 : ICRS1 = MIN (NORD, ICRS1 + 1)
15341 0 : ICRS2 = MIN (NORD, ICRS2 + 1)
15342 : End Do
15343 : Else
15344 0 : Do ICRS = IENDT (IDON1), IDON, -1
15345 0 : If (XWRKT(ICRS) > XWRK1) Then
15346 0 : XWRK = XWRKT (ICRS)
15347 0 : IDCR = ICRS1 - 1
15348 0 : Do IDCR = ICRS1 - 1, 1, - 1
15349 0 : If (XWRK <= XWRKT(IDCR)) Exit
15350 0 : XWRKT (IDCR + 1) = XWRKT (IDCR)
15351 : End Do
15352 0 : XWRKT (IDCR + 1) = XWRK
15353 0 : XWRK1 = XWRKT(ICRS1)
15354 : Else
15355 : Exit
15356 : End If
15357 : End Do
15358 : end if
15359 : End Do
15360 : !
15361 0 : res_med = XWRK1
15362 0 : Return
15363 : End If
15364 : !
15365 : End Function I_valmed
15366 :
15367 0 : Function D_valnth (XDONT, NORD) Result (valnth)
15368 : ! Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
15369 : ! __________________________________________________________
15370 : ! This routine uses a pivoting strategy such as the one of
15371 : ! finding the median based on the quicksort algorithm, but
15372 : ! we skew the pivot choice to try to bring it to NORD as
15373 : ! fast as possible. It uses 2 temporary arrays, where it
15374 : ! stores the indices of the values smaller than the pivot
15375 : ! (ILOWT), and the indices of values larger than the pivot
15376 : ! that we might still need later on (IHIGT). It iterates
15377 : ! until it can bring the number of values in ILOWT to
15378 : ! exactly NORD, and then finds the maximum of this set.
15379 : ! Michel Olagnon - Aug. 2000
15380 : ! __________________________________________________________
15381 : ! __________________________________________________________
15382 : real(Kind = dp), Dimension (:), Intent (In) :: XDONT
15383 : real(Kind = dp) :: valnth
15384 : Integer(kind = i4), Intent (In) :: NORD
15385 : ! __________________________________________________________
15386 0 : real(Kind = dp), Dimension (SIZE(XDONT)) :: XLOWT, XHIGT
15387 0 : real(Kind = dp) :: XPIV, XWRK, XWRK1, XWRK2, XWRK3, XMIN, XMAX
15388 : !
15389 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG
15390 : Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
15391 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
15392 : !
15393 0 : NDON = SIZE (XDONT)
15394 0 : INTH = MAX (MIN (NORD, NDON), 1)
15395 : !
15396 : ! First loop is used to fill-in XLOWT, XHIGT at the same time
15397 : !
15398 0 : If (NDON < 2) Then
15399 0 : If (INTH == 1) VALNTH = XDONT (1)
15400 0 : Return
15401 : End If
15402 : !
15403 : ! One chooses a pivot, best estimate possible to put fractile near
15404 : ! mid-point of the set of low values.
15405 : !
15406 0 : If (XDONT(2) < XDONT(1)) Then
15407 0 : XLOWT (1) = XDONT(2)
15408 0 : XHIGT (1) = XDONT(1)
15409 : Else
15410 0 : XLOWT (1) = XDONT(1)
15411 0 : XHIGT (1) = XDONT(2)
15412 : End If
15413 : !
15414 0 : If (NDON < 3) Then
15415 0 : If (INTH == 1) VALNTH = XLOWT (1)
15416 0 : If (INTH == 2) VALNTH = XHIGT (1)
15417 0 : Return
15418 : End If
15419 : !
15420 0 : If (XDONT(3) < XHIGT(1)) Then
15421 0 : XHIGT (2) = XHIGT (1)
15422 0 : If (XDONT(3) < XLOWT(1)) Then
15423 0 : XHIGT (1) = XLOWT (1)
15424 0 : XLOWT (1) = XDONT(3)
15425 : Else
15426 0 : XHIGT (1) = XDONT(3)
15427 : End If
15428 : Else
15429 0 : XHIGT (2) = XDONT(3)
15430 : End If
15431 : !
15432 0 : If (NDON < 4) Then
15433 0 : If (INTH == 1) Then
15434 0 : VALNTH = XLOWT (1)
15435 : Else
15436 0 : VALNTH = XHIGT (INTH - 1)
15437 : End If
15438 0 : Return
15439 : End If
15440 : !
15441 0 : If (XDONT(NDON) < XHIGT(1)) Then
15442 0 : XHIGT (3) = XHIGT (2)
15443 0 : XHIGT (2) = XHIGT (1)
15444 0 : If (XDONT(NDON) < XLOWT(1)) Then
15445 0 : XHIGT (1) = XLOWT (1)
15446 0 : XLOWT (1) = XDONT(NDON)
15447 : Else
15448 0 : XHIGT (1) = XDONT(NDON)
15449 : End If
15450 : Else
15451 0 : XHIGT (3) = XDONT(NDON)
15452 : End If
15453 : !
15454 0 : If (NDON < 5) Then
15455 0 : If (INTH == 1) Then
15456 0 : VALNTH = XLOWT (1)
15457 : Else
15458 0 : VALNTH = XHIGT (INTH - 1)
15459 : End If
15460 0 : Return
15461 : End If
15462 : !
15463 :
15464 0 : JLOW = 1
15465 0 : JHIG = 3
15466 0 : XPIV = XLOWT(1) + REAL(2 * INTH, dp) / REAL(NDON + INTH, dp) * (XHIGT(3) - XLOWT(1))
15467 0 : If (XPIV >= XHIGT(1)) Then
15468 : XPIV = XLOWT(1) + REAL(2 * INTH, dp) / REAL(NDON + INTH, dp) * &
15469 0 : (XHIGT(2) - XLOWT(1))
15470 0 : If (XPIV >= XHIGT(1)) &
15471 : XPIV = XLOWT(1) + REAL(2 * INTH, dp) / REAL(NDON + INTH, dp) * &
15472 0 : (XHIGT(1) - XLOWT(1))
15473 : End If
15474 : !
15475 : ! One puts values > pivot in the end and those <= pivot
15476 : ! at the beginning. This is split in 2 cases, so that
15477 : ! we can skip the loop test a number of times.
15478 : ! As we are also filling in the work arrays at the same time
15479 : ! we stop filling in the XHIGT array as soon as we have more
15480 : ! than enough values in XLOWT.
15481 : !
15482 : !
15483 0 : If (XDONT(NDON) > XPIV) Then
15484 : ICRS = 3
15485 : Do
15486 0 : ICRS = ICRS + 1
15487 0 : If (XDONT(ICRS) > XPIV) Then
15488 0 : If (ICRS >= NDON) Exit
15489 0 : JHIG = JHIG + 1
15490 0 : XHIGT (JHIG) = XDONT(ICRS)
15491 : Else
15492 0 : JLOW = JLOW + 1
15493 0 : XLOWT (JLOW) = XDONT(ICRS)
15494 0 : If (JLOW >= INTH) Exit
15495 : End If
15496 : End Do
15497 : !
15498 : ! One restricts further processing because it is no use
15499 : ! to store more high values
15500 : !
15501 0 : If (ICRS < NDON - 1) Then
15502 : Do
15503 0 : ICRS = ICRS + 1
15504 0 : If (XDONT(ICRS) <= XPIV) Then
15505 0 : JLOW = JLOW + 1
15506 0 : XLOWT (JLOW) = XDONT(ICRS)
15507 0 : Else If (ICRS >= NDON) Then
15508 : Exit
15509 : End If
15510 : End Do
15511 : End If
15512 : !
15513 : !
15514 : Else
15515 : !
15516 : ! Same as above, but this is not as easy to optimize, so the
15517 : ! DO-loop is kept
15518 : !
15519 0 : Do ICRS = 4, NDON - 1
15520 0 : If (XDONT(ICRS) > XPIV) Then
15521 0 : JHIG = JHIG + 1
15522 0 : XHIGT (JHIG) = XDONT(ICRS)
15523 : Else
15524 0 : JLOW = JLOW + 1
15525 0 : XLOWT (JLOW) = XDONT(ICRS)
15526 0 : If (JLOW >= INTH) Exit
15527 : End If
15528 : End Do
15529 : !
15530 0 : If (ICRS < NDON - 1) Then
15531 : Do
15532 0 : ICRS = ICRS + 1
15533 0 : If (XDONT(ICRS) <= XPIV) Then
15534 0 : If (ICRS >= NDON) Exit
15535 0 : JLOW = JLOW + 1
15536 0 : XLOWT (JLOW) = XDONT(ICRS)
15537 : End If
15538 : End Do
15539 : End If
15540 : End If
15541 : !
15542 : JLM2 = 0
15543 : JLM1 = 0
15544 : JHM2 = 0
15545 : JHM1 = 0
15546 : Do
15547 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
15548 : !
15549 : ! We are oscillating. Perturbate by bringing JLOW closer by one
15550 : ! to INTH
15551 : !
15552 0 : If (INTH > JLOW) Then
15553 0 : XMIN = XHIGT(1)
15554 0 : IHIG = 1
15555 0 : Do ICRS = 2, JHIG
15556 0 : If (XHIGT(ICRS) < XMIN) Then
15557 0 : XMIN = XHIGT(ICRS)
15558 0 : IHIG = ICRS
15559 : End If
15560 : End Do
15561 : !
15562 0 : JLOW = JLOW + 1
15563 0 : XLOWT (JLOW) = XHIGT (IHIG)
15564 0 : XHIGT (IHIG) = XHIGT (JHIG)
15565 0 : JHIG = JHIG - 1
15566 : Else
15567 :
15568 0 : XMAX = XLOWT (JLOW)
15569 0 : JLOW = JLOW - 1
15570 0 : Do ICRS = 1, JLOW
15571 0 : If (XLOWT(ICRS) > XMAX) Then
15572 0 : XWRK = XMAX
15573 0 : XMAX = XLOWT(ICRS)
15574 0 : XLOWT (ICRS) = XWRK
15575 : End If
15576 : End Do
15577 : End If
15578 : End If
15579 0 : JLM2 = JLM1
15580 0 : JLM1 = JLOW
15581 0 : JHM2 = JHM1
15582 0 : JHM1 = JHIG
15583 : !
15584 : ! We try to bring the number of values in the low values set
15585 : ! closer to INTH.
15586 : !
15587 0 : Select Case (INTH - JLOW)
15588 : Case (2 :)
15589 : !
15590 : ! Not enough values in low part, at least 2 are missing
15591 : !
15592 0 : INTH = INTH - JLOW
15593 0 : JLOW = 0
15594 : Select Case (JHIG)
15595 : !!!!! CASE DEFAULT
15596 : !!!!! write (unit=*,fmt=*) "Assertion failed"
15597 : !!!!! STOP
15598 : !
15599 : ! We make a special case when we have so few values in
15600 : ! the high values set that it is bad performance to choose a pivot
15601 : ! and apply the general algorithm.
15602 : !
15603 : Case (2)
15604 0 : If (XHIGT(1) <= XHIGT(2)) Then
15605 0 : JLOW = JLOW + 1
15606 0 : XLOWT (JLOW) = XHIGT (1)
15607 0 : JLOW = JLOW + 1
15608 0 : XLOWT (JLOW) = XHIGT (2)
15609 : Else
15610 0 : JLOW = JLOW + 1
15611 0 : XLOWT (JLOW) = XHIGT (2)
15612 0 : JLOW = JLOW + 1
15613 0 : XLOWT (JLOW) = XHIGT (1)
15614 : End If
15615 : Exit
15616 : !
15617 : Case (3)
15618 : !
15619 : !
15620 0 : XWRK1 = XHIGT (1)
15621 0 : XWRK2 = XHIGT (2)
15622 0 : XWRK3 = XHIGT (3)
15623 0 : If (XWRK2 < XWRK1) Then
15624 0 : XHIGT (1) = XWRK2
15625 0 : XHIGT (2) = XWRK1
15626 0 : XWRK2 = XWRK1
15627 : End If
15628 0 : If (XWRK2 > XWRK3) Then
15629 0 : XHIGT (3) = XWRK2
15630 0 : XHIGT (2) = XWRK3
15631 0 : XWRK2 = XWRK3
15632 0 : If (XWRK2 < XHIGT(1)) Then
15633 0 : XHIGT (2) = XHIGT (1)
15634 0 : XHIGT (1) = XWRK2
15635 : End If
15636 : End If
15637 : JHIG = 0
15638 0 : Do ICRS = JLOW + 1, INTH
15639 0 : JHIG = JHIG + 1
15640 0 : XLOWT (ICRS) = XHIGT (JHIG)
15641 : End Do
15642 0 : JLOW = INTH
15643 : Exit
15644 : !
15645 : Case (4 :)
15646 : !
15647 : !
15648 0 : IFIN = JHIG
15649 : !
15650 : ! One chooses a pivot from the 2 first values and the last one.
15651 : ! This should ensure sufficient renewal between iterations to
15652 : ! avoid worst case behavior effects.
15653 : !
15654 0 : XWRK1 = XHIGT (1)
15655 0 : XWRK2 = XHIGT (2)
15656 0 : XWRK3 = XHIGT (IFIN)
15657 0 : If (XWRK2 < XWRK1) Then
15658 0 : XHIGT (1) = XWRK2
15659 0 : XHIGT (2) = XWRK1
15660 0 : XWRK2 = XWRK1
15661 : End If
15662 0 : If (XWRK2 > XWRK3) Then
15663 0 : XHIGT (IFIN) = XWRK2
15664 0 : XHIGT (2) = XWRK3
15665 0 : XWRK2 = XWRK3
15666 0 : If (XWRK2 < XHIGT(1)) Then
15667 0 : XHIGT (2) = XHIGT (1)
15668 0 : XHIGT (1) = XWRK2
15669 : End If
15670 : End If
15671 : !
15672 0 : XWRK1 = XHIGT (1)
15673 0 : JLOW = JLOW + 1
15674 0 : XLOWT (JLOW) = XWRK1
15675 0 : XPIV = XWRK1 + 0.5 * (XHIGT(IFIN) - XWRK1)
15676 : !
15677 : ! One takes values <= pivot to XLOWT
15678 : ! Again, 2 parts, one where we take care of the remaining
15679 : ! high values because we might still need them, and the
15680 : ! other when we know that we will have more than enough
15681 : ! low values in the end.
15682 : !
15683 0 : JHIG = 0
15684 0 : Do ICRS = 2, IFIN
15685 0 : If (XHIGT(ICRS) <= XPIV) Then
15686 0 : JLOW = JLOW + 1
15687 0 : XLOWT (JLOW) = XHIGT (ICRS)
15688 0 : If (JLOW >= INTH) Exit
15689 : Else
15690 0 : JHIG = JHIG + 1
15691 0 : XHIGT (JHIG) = XHIGT (ICRS)
15692 : End If
15693 : End Do
15694 : !
15695 0 : Do ICRS = ICRS + 1, IFIN
15696 0 : If (XHIGT(ICRS) <= XPIV) Then
15697 0 : JLOW = JLOW + 1
15698 0 : XLOWT (JLOW) = XHIGT (ICRS)
15699 : End If
15700 : End Do
15701 : End Select
15702 : !
15703 : !
15704 : Case (1)
15705 : !
15706 : ! Only 1 value is missing in low part
15707 : !
15708 0 : XMIN = XHIGT(1)
15709 0 : IHIG = 1
15710 0 : Do ICRS = 2, JHIG
15711 0 : If (XHIGT(ICRS) < XMIN) Then
15712 0 : XMIN = XHIGT(ICRS)
15713 0 : IHIG = ICRS
15714 : End If
15715 : End Do
15716 : !
15717 0 : VALNTH = XHIGT (IHIG)
15718 0 : Return
15719 : !
15720 : !
15721 : Case (0)
15722 : !
15723 : ! Low part is exactly what we want
15724 : !
15725 : Exit
15726 : !
15727 : !
15728 : Case (-5 : -1)
15729 : !
15730 : ! Only few values too many in low part
15731 : !
15732 0 : XHIGT (1) = XLOWT (1)
15733 0 : ILOW = 1 + INTH - JLOW
15734 0 : Do ICRS = 2, INTH
15735 0 : XWRK = XLOWT (ICRS)
15736 0 : Do IDCR = ICRS - 1, MAX (1, ILOW), - 1
15737 0 : If (XWRK < XHIGT(IDCR)) Then
15738 0 : XHIGT (IDCR + 1) = XHIGT (IDCR)
15739 : Else
15740 : Exit
15741 : End If
15742 : End Do
15743 0 : XHIGT (IDCR + 1) = XWRK
15744 0 : ILOW = ILOW + 1
15745 : End Do
15746 : !
15747 0 : XWRK1 = XHIGT(INTH)
15748 0 : ILOW = 2 * INTH - JLOW
15749 0 : Do ICRS = INTH + 1, JLOW
15750 0 : If (XLOWT (ICRS) < XWRK1) Then
15751 0 : XWRK = XLOWT (ICRS)
15752 0 : Do IDCR = INTH - 1, MAX (1, ILOW), - 1
15753 0 : If (XWRK >= XHIGT(IDCR)) Exit
15754 0 : XHIGT (IDCR + 1) = XHIGT (IDCR)
15755 : End Do
15756 0 : XHIGT (IDCR + 1) = XLOWT (ICRS)
15757 0 : XWRK1 = XHIGT(INTH)
15758 : End If
15759 0 : ILOW = ILOW + 1
15760 : End Do
15761 : !
15762 0 : VALNTH = XHIGT(INTH)
15763 0 : Return
15764 : !
15765 : !
15766 : Case (: -6)
15767 : !
15768 : ! last case: too many values in low part
15769 : !
15770 :
15771 0 : IMIL = (JLOW + 1) / 2
15772 0 : IFIN = JLOW
15773 : !
15774 : ! One chooses a pivot from 1st, last, and middle values
15775 : !
15776 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
15777 0 : XWRK = XLOWT (1)
15778 0 : XLOWT (1) = XLOWT (IMIL)
15779 0 : XLOWT (IMIL) = XWRK
15780 : End If
15781 0 : If (XLOWT(IMIL) > XLOWT(IFIN)) Then
15782 0 : XWRK = XLOWT (IFIN)
15783 0 : XLOWT (IFIN) = XLOWT (IMIL)
15784 0 : XLOWT (IMIL) = XWRK
15785 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
15786 0 : XWRK = XLOWT (1)
15787 0 : XLOWT (1) = XLOWT (IMIL)
15788 0 : XLOWT (IMIL) = XWRK
15789 : End If
15790 : End If
15791 0 : If (IFIN <= 3) Exit
15792 : !
15793 : XPIV = XLOWT(1) + REAL(INTH, dp) / REAL(JLOW + INTH, dp) * &
15794 0 : (XLOWT(IFIN) - XLOWT(1))
15795 :
15796 : !
15797 : ! One takes values > XPIV to XHIGT
15798 : !
15799 0 : JHIG = 0
15800 0 : JLOW = 0
15801 : !
15802 0 : If (XLOWT(IFIN) > XPIV) Then
15803 : ICRS = 0
15804 : Do
15805 0 : ICRS = ICRS + 1
15806 0 : If (XLOWT(ICRS) > XPIV) Then
15807 0 : JHIG = JHIG + 1
15808 0 : XHIGT (JHIG) = XLOWT (ICRS)
15809 0 : If (ICRS >= IFIN) Exit
15810 : Else
15811 0 : JLOW = JLOW + 1
15812 0 : XLOWT (JLOW) = XLOWT (ICRS)
15813 0 : If (JLOW >= INTH) Exit
15814 : End If
15815 : End Do
15816 : !
15817 0 : If (ICRS < IFIN) Then
15818 : Do
15819 0 : ICRS = ICRS + 1
15820 0 : If (XLOWT(ICRS) <= XPIV) Then
15821 0 : JLOW = JLOW + 1
15822 0 : XLOWT (JLOW) = XLOWT (ICRS)
15823 : Else
15824 0 : If (ICRS >= IFIN) Exit
15825 : End If
15826 : End Do
15827 : End If
15828 : Else
15829 0 : Do ICRS = 1, IFIN
15830 0 : If (XLOWT(ICRS) > XPIV) Then
15831 0 : JHIG = JHIG + 1
15832 0 : XHIGT (JHIG) = XLOWT (ICRS)
15833 : Else
15834 0 : JLOW = JLOW + 1
15835 0 : XLOWT (JLOW) = XLOWT (ICRS)
15836 0 : If (JLOW >= INTH) Exit
15837 : End If
15838 : End Do
15839 : !
15840 0 : Do ICRS = ICRS + 1, IFIN
15841 0 : If (XLOWT(ICRS) <= XPIV) Then
15842 0 : JLOW = JLOW + 1
15843 0 : XLOWT (JLOW) = XLOWT (ICRS)
15844 : End If
15845 : End Do
15846 : End If
15847 : !
15848 : End Select
15849 : !
15850 : End Do
15851 : !
15852 : ! Now, we only need to find maximum of the 1:INTH set
15853 : !
15854 0 : VALNTH = MAXVAL (XLOWT (1 : INTH))
15855 : Return
15856 : !
15857 : !
15858 0 : End Function D_valnth
15859 :
15860 0 : Function R_valnth (XDONT, NORD) Result (valnth)
15861 : ! Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
15862 : ! __________________________________________________________
15863 : ! This routine uses a pivoting strategy such as the one of
15864 : ! finding the median based on the quicksort algorithm, but
15865 : ! we skew the pivot choice to try to bring it to NORD as
15866 : ! fast as possible. It uses 2 temporary arrays, where it
15867 : ! stores the indices of the values smaller than the pivot
15868 : ! (ILOWT), and the indices of values larger than the pivot
15869 : ! that we might still need later on (IHIGT). It iterates
15870 : ! until it can bring the number of values in ILOWT to
15871 : ! exactly NORD, and then finds the maximum of this set.
15872 : ! Michel Olagnon - Aug. 2000
15873 : ! __________________________________________________________
15874 : ! _________________________________________________________
15875 : Real(kind = sp), Dimension (:), Intent (In) :: XDONT
15876 : Real(kind = sp) :: valnth
15877 : Integer(kind = i4), Intent (In) :: NORD
15878 : ! __________________________________________________________
15879 0 : Real(kind = sp), Dimension (SIZE(XDONT)) :: XLOWT, XHIGT
15880 0 : Real(kind = sp) :: XPIV, XWRK, XWRK1, XWRK2, XWRK3, XMIN, XMAX
15881 : !
15882 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG
15883 : Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
15884 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
15885 : !
15886 0 : NDON = SIZE (XDONT)
15887 0 : INTH = MAX (MIN (NORD, NDON), 1)
15888 : !
15889 : ! First loop is used to fill-in XLOWT, XHIGT at the same time
15890 : !
15891 0 : If (NDON < 2) Then
15892 0 : If (INTH == 1) VALNTH = XDONT (1)
15893 0 : Return
15894 : End If
15895 : !
15896 : ! One chooses a pivot, best estimate possible to put fractile near
15897 : ! mid-point of the set of low values.
15898 : !
15899 0 : If (XDONT(2) < XDONT(1)) Then
15900 0 : XLOWT (1) = XDONT(2)
15901 0 : XHIGT (1) = XDONT(1)
15902 : Else
15903 0 : XLOWT (1) = XDONT(1)
15904 0 : XHIGT (1) = XDONT(2)
15905 : End If
15906 : !
15907 0 : If (NDON < 3) Then
15908 0 : If (INTH == 1) VALNTH = XLOWT (1)
15909 0 : If (INTH == 2) VALNTH = XHIGT (1)
15910 0 : Return
15911 : End If
15912 : !
15913 0 : If (XDONT(3) < XHIGT(1)) Then
15914 0 : XHIGT (2) = XHIGT (1)
15915 0 : If (XDONT(3) < XLOWT(1)) Then
15916 0 : XHIGT (1) = XLOWT (1)
15917 0 : XLOWT (1) = XDONT(3)
15918 : Else
15919 0 : XHIGT (1) = XDONT(3)
15920 : End If
15921 : Else
15922 0 : XHIGT (2) = XDONT(3)
15923 : End If
15924 : !
15925 0 : If (NDON < 4) Then
15926 0 : If (INTH == 1) Then
15927 0 : VALNTH = XLOWT (1)
15928 : Else
15929 0 : VALNTH = XHIGT (INTH - 1)
15930 : End If
15931 0 : Return
15932 : End If
15933 : !
15934 0 : If (XDONT(NDON) < XHIGT(1)) Then
15935 0 : XHIGT (3) = XHIGT (2)
15936 0 : XHIGT (2) = XHIGT (1)
15937 0 : If (XDONT(NDON) < XLOWT(1)) Then
15938 0 : XHIGT (1) = XLOWT (1)
15939 0 : XLOWT (1) = XDONT(NDON)
15940 : Else
15941 0 : XHIGT (1) = XDONT(NDON)
15942 : End If
15943 : Else
15944 0 : XHIGT (3) = XDONT(NDON)
15945 : End If
15946 : !
15947 0 : If (NDON < 5) Then
15948 0 : If (INTH == 1) Then
15949 0 : VALNTH = XLOWT (1)
15950 : Else
15951 0 : VALNTH = XHIGT (INTH - 1)
15952 : End If
15953 0 : Return
15954 : End If
15955 : !
15956 :
15957 0 : JLOW = 1
15958 0 : JHIG = 3
15959 0 : XPIV = XLOWT(1) + REAL(2 * INTH, sp) / REAL(NDON + INTH, sp) * (XHIGT(3) - XLOWT(1))
15960 0 : If (XPIV >= XHIGT(1)) Then
15961 : XPIV = XLOWT(1) + REAL(2 * INTH, sp) / REAL(NDON + INTH, sp) * &
15962 0 : (XHIGT(2) - XLOWT(1))
15963 0 : If (XPIV >= XHIGT(1)) &
15964 : XPIV = XLOWT(1) + REAL(2 * INTH, sp) / REAL(NDON + INTH, sp) * &
15965 0 : (XHIGT(1) - XLOWT(1))
15966 : End If
15967 : !
15968 : ! One puts values > pivot in the end and those <= pivot
15969 : ! at the beginning. This is split in 2 cases, so that
15970 : ! we can skip the loop test a number of times.
15971 : ! As we are also filling in the work arrays at the same time
15972 : ! we stop filling in the XHIGT array as soon as we have more
15973 : ! than enough values in XLOWT.
15974 : !
15975 : !
15976 0 : If (XDONT(NDON) > XPIV) Then
15977 : ICRS = 3
15978 : Do
15979 0 : ICRS = ICRS + 1
15980 0 : If (XDONT(ICRS) > XPIV) Then
15981 0 : If (ICRS >= NDON) Exit
15982 0 : JHIG = JHIG + 1
15983 0 : XHIGT (JHIG) = XDONT(ICRS)
15984 : Else
15985 0 : JLOW = JLOW + 1
15986 0 : XLOWT (JLOW) = XDONT(ICRS)
15987 0 : If (JLOW >= INTH) Exit
15988 : End If
15989 : End Do
15990 : !
15991 : ! One restricts further processing because it is no use
15992 : ! to store more high values
15993 : !
15994 0 : If (ICRS < NDON - 1) Then
15995 : Do
15996 0 : ICRS = ICRS + 1
15997 0 : If (XDONT(ICRS) <= XPIV) Then
15998 0 : JLOW = JLOW + 1
15999 0 : XLOWT (JLOW) = XDONT(ICRS)
16000 0 : Else If (ICRS >= NDON) Then
16001 : Exit
16002 : End If
16003 : End Do
16004 : End If
16005 : !
16006 : !
16007 : Else
16008 : !
16009 : ! Same as above, but this is not as easy to optimize, so the
16010 : ! DO-loop is kept
16011 : !
16012 0 : Do ICRS = 4, NDON - 1
16013 0 : If (XDONT(ICRS) > XPIV) Then
16014 0 : JHIG = JHIG + 1
16015 0 : XHIGT (JHIG) = XDONT(ICRS)
16016 : Else
16017 0 : JLOW = JLOW + 1
16018 0 : XLOWT (JLOW) = XDONT(ICRS)
16019 0 : If (JLOW >= INTH) Exit
16020 : End If
16021 : End Do
16022 : !
16023 0 : If (ICRS < NDON - 1) Then
16024 : Do
16025 0 : ICRS = ICRS + 1
16026 0 : If (XDONT(ICRS) <= XPIV) Then
16027 0 : If (ICRS >= NDON) Exit
16028 0 : JLOW = JLOW + 1
16029 0 : XLOWT (JLOW) = XDONT(ICRS)
16030 : End If
16031 : End Do
16032 : End If
16033 : End If
16034 : !
16035 : JLM2 = 0
16036 : JLM1 = 0
16037 : JHM2 = 0
16038 : JHM1 = 0
16039 : Do
16040 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
16041 : !
16042 : ! We are oscillating. Perturbate by bringing JLOW closer by one
16043 : ! to INTH
16044 : !
16045 0 : If (INTH > JLOW) Then
16046 0 : XMIN = XHIGT(1)
16047 0 : IHIG = 1
16048 0 : Do ICRS = 2, JHIG
16049 0 : If (XHIGT(ICRS) < XMIN) Then
16050 0 : XMIN = XHIGT(ICRS)
16051 0 : IHIG = ICRS
16052 : End If
16053 : End Do
16054 : !
16055 0 : JLOW = JLOW + 1
16056 0 : XLOWT (JLOW) = XHIGT (IHIG)
16057 0 : XHIGT (IHIG) = XHIGT (JHIG)
16058 0 : JHIG = JHIG - 1
16059 : Else
16060 :
16061 0 : XMAX = XLOWT (JLOW)
16062 0 : JLOW = JLOW - 1
16063 0 : Do ICRS = 1, JLOW
16064 0 : If (XLOWT(ICRS) > XMAX) Then
16065 0 : XWRK = XMAX
16066 0 : XMAX = XLOWT(ICRS)
16067 0 : XLOWT (ICRS) = XWRK
16068 : End If
16069 : End Do
16070 : End If
16071 : End If
16072 0 : JLM2 = JLM1
16073 0 : JLM1 = JLOW
16074 0 : JHM2 = JHM1
16075 0 : JHM1 = JHIG
16076 : !
16077 : ! We try to bring the number of values in the low values set
16078 : ! closer to INTH.
16079 : !
16080 0 : Select Case (INTH - JLOW)
16081 : Case (2 :)
16082 : !
16083 : ! Not enough values in low part, at least 2 are missing
16084 : !
16085 0 : INTH = INTH - JLOW
16086 0 : JLOW = 0
16087 : Select Case (JHIG)
16088 : !!!!! CASE DEFAULT
16089 : !!!!! write (unit=*,fmt=*) "Assertion failed"
16090 : !!!!! STOP
16091 : !
16092 : ! We make a special case when we have so few values in
16093 : ! the high values set that it is bad performance to choose a pivot
16094 : ! and apply the general algorithm.
16095 : !
16096 : Case (2)
16097 0 : If (XHIGT(1) <= XHIGT(2)) Then
16098 0 : JLOW = JLOW + 1
16099 0 : XLOWT (JLOW) = XHIGT (1)
16100 0 : JLOW = JLOW + 1
16101 0 : XLOWT (JLOW) = XHIGT (2)
16102 : Else
16103 0 : JLOW = JLOW + 1
16104 0 : XLOWT (JLOW) = XHIGT (2)
16105 0 : JLOW = JLOW + 1
16106 0 : XLOWT (JLOW) = XHIGT (1)
16107 : End If
16108 : Exit
16109 : !
16110 : Case (3)
16111 : !
16112 : !
16113 0 : XWRK1 = XHIGT (1)
16114 0 : XWRK2 = XHIGT (2)
16115 0 : XWRK3 = XHIGT (3)
16116 0 : If (XWRK2 < XWRK1) Then
16117 0 : XHIGT (1) = XWRK2
16118 0 : XHIGT (2) = XWRK1
16119 0 : XWRK2 = XWRK1
16120 : End If
16121 0 : If (XWRK2 > XWRK3) Then
16122 0 : XHIGT (3) = XWRK2
16123 0 : XHIGT (2) = XWRK3
16124 0 : XWRK2 = XWRK3
16125 0 : If (XWRK2 < XHIGT(1)) Then
16126 0 : XHIGT (2) = XHIGT (1)
16127 0 : XHIGT (1) = XWRK2
16128 : End If
16129 : End If
16130 : JHIG = 0
16131 0 : Do ICRS = JLOW + 1, INTH
16132 0 : JHIG = JHIG + 1
16133 0 : XLOWT (ICRS) = XHIGT (JHIG)
16134 : End Do
16135 0 : JLOW = INTH
16136 : Exit
16137 : !
16138 : Case (4 :)
16139 : !
16140 : !
16141 0 : IFIN = JHIG
16142 : !
16143 : ! One chooses a pivot from the 2 first values and the last one.
16144 : ! This should ensure sufficient renewal between iterations to
16145 : ! avoid worst case behavior effects.
16146 : !
16147 0 : XWRK1 = XHIGT (1)
16148 0 : XWRK2 = XHIGT (2)
16149 0 : XWRK3 = XHIGT (IFIN)
16150 0 : If (XWRK2 < XWRK1) Then
16151 0 : XHIGT (1) = XWRK2
16152 0 : XHIGT (2) = XWRK1
16153 0 : XWRK2 = XWRK1
16154 : End If
16155 0 : If (XWRK2 > XWRK3) Then
16156 0 : XHIGT (IFIN) = XWRK2
16157 0 : XHIGT (2) = XWRK3
16158 0 : XWRK2 = XWRK3
16159 0 : If (XWRK2 < XHIGT(1)) Then
16160 0 : XHIGT (2) = XHIGT (1)
16161 0 : XHIGT (1) = XWRK2
16162 : End If
16163 : End If
16164 : !
16165 0 : XWRK1 = XHIGT (1)
16166 0 : JLOW = JLOW + 1
16167 0 : XLOWT (JLOW) = XWRK1
16168 0 : XPIV = XWRK1 + 0.5 * (XHIGT(IFIN) - XWRK1)
16169 : !
16170 : ! One takes values <= pivot to XLOWT
16171 : ! Again, 2 parts, one where we take care of the remaining
16172 : ! high values because we might still need them, and the
16173 : ! other when we know that we will have more than enough
16174 : ! low values in the end.
16175 : !
16176 0 : JHIG = 0
16177 0 : Do ICRS = 2, IFIN
16178 0 : If (XHIGT(ICRS) <= XPIV) Then
16179 0 : JLOW = JLOW + 1
16180 0 : XLOWT (JLOW) = XHIGT (ICRS)
16181 0 : If (JLOW >= INTH) Exit
16182 : Else
16183 0 : JHIG = JHIG + 1
16184 0 : XHIGT (JHIG) = XHIGT (ICRS)
16185 : End If
16186 : End Do
16187 : !
16188 0 : Do ICRS = ICRS + 1, IFIN
16189 0 : If (XHIGT(ICRS) <= XPIV) Then
16190 0 : JLOW = JLOW + 1
16191 0 : XLOWT (JLOW) = XHIGT (ICRS)
16192 : End If
16193 : End Do
16194 : End Select
16195 : !
16196 : !
16197 : Case (1)
16198 : !
16199 : ! Only 1 value is missing in low part
16200 : !
16201 0 : XMIN = XHIGT(1)
16202 0 : IHIG = 1
16203 0 : Do ICRS = 2, JHIG
16204 0 : If (XHIGT(ICRS) < XMIN) Then
16205 0 : XMIN = XHIGT(ICRS)
16206 0 : IHIG = ICRS
16207 : End If
16208 : End Do
16209 : !
16210 0 : VALNTH = XHIGT (IHIG)
16211 0 : Return
16212 : !
16213 : !
16214 : Case (0)
16215 : !
16216 : ! Low part is exactly what we want
16217 : !
16218 : Exit
16219 : !
16220 : !
16221 : Case (-5 : -1)
16222 : !
16223 : ! Only few values too many in low part
16224 : !
16225 0 : XHIGT (1) = XLOWT (1)
16226 0 : ILOW = 1 + INTH - JLOW
16227 0 : Do ICRS = 2, INTH
16228 0 : XWRK = XLOWT (ICRS)
16229 0 : Do IDCR = ICRS - 1, MAX (1, ILOW), - 1
16230 0 : If (XWRK < XHIGT(IDCR)) Then
16231 0 : XHIGT (IDCR + 1) = XHIGT (IDCR)
16232 : Else
16233 : Exit
16234 : End If
16235 : End Do
16236 0 : XHIGT (IDCR + 1) = XWRK
16237 0 : ILOW = ILOW + 1
16238 : End Do
16239 : !
16240 0 : XWRK1 = XHIGT(INTH)
16241 0 : ILOW = 2 * INTH - JLOW
16242 0 : Do ICRS = INTH + 1, JLOW
16243 0 : If (XLOWT (ICRS) < XWRK1) Then
16244 0 : XWRK = XLOWT (ICRS)
16245 0 : Do IDCR = INTH - 1, MAX (1, ILOW), - 1
16246 0 : If (XWRK >= XHIGT(IDCR)) Exit
16247 0 : XHIGT (IDCR + 1) = XHIGT (IDCR)
16248 : End Do
16249 0 : XHIGT (IDCR + 1) = XLOWT (ICRS)
16250 0 : XWRK1 = XHIGT(INTH)
16251 : End If
16252 0 : ILOW = ILOW + 1
16253 : End Do
16254 : !
16255 0 : VALNTH = XHIGT(INTH)
16256 0 : Return
16257 : !
16258 : !
16259 : Case (: -6)
16260 : !
16261 : ! last case: too many values in low part
16262 : !
16263 :
16264 0 : IMIL = (JLOW + 1) / 2
16265 0 : IFIN = JLOW
16266 : !
16267 : ! One chooses a pivot from 1st, last, and middle values
16268 : !
16269 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
16270 0 : XWRK = XLOWT (1)
16271 0 : XLOWT (1) = XLOWT (IMIL)
16272 0 : XLOWT (IMIL) = XWRK
16273 : End If
16274 0 : If (XLOWT(IMIL) > XLOWT(IFIN)) Then
16275 0 : XWRK = XLOWT (IFIN)
16276 0 : XLOWT (IFIN) = XLOWT (IMIL)
16277 0 : XLOWT (IMIL) = XWRK
16278 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
16279 0 : XWRK = XLOWT (1)
16280 0 : XLOWT (1) = XLOWT (IMIL)
16281 0 : XLOWT (IMIL) = XWRK
16282 : End If
16283 : End If
16284 0 : If (IFIN <= 3) Exit
16285 : !
16286 : XPIV = XLOWT(1) + REAL(INTH, sp) / REAL(JLOW + INTH, sp) * &
16287 0 : (XLOWT(IFIN) - XLOWT(1))
16288 :
16289 : !
16290 : ! One takes values > XPIV to XHIGT
16291 : !
16292 0 : JHIG = 0
16293 0 : JLOW = 0
16294 : !
16295 0 : If (XLOWT(IFIN) > XPIV) Then
16296 : ICRS = 0
16297 : Do
16298 0 : ICRS = ICRS + 1
16299 0 : If (XLOWT(ICRS) > XPIV) Then
16300 0 : JHIG = JHIG + 1
16301 0 : XHIGT (JHIG) = XLOWT (ICRS)
16302 0 : If (ICRS >= IFIN) Exit
16303 : Else
16304 0 : JLOW = JLOW + 1
16305 0 : XLOWT (JLOW) = XLOWT (ICRS)
16306 0 : If (JLOW >= INTH) Exit
16307 : End If
16308 : End Do
16309 : !
16310 0 : If (ICRS < IFIN) Then
16311 : Do
16312 0 : ICRS = ICRS + 1
16313 0 : If (XLOWT(ICRS) <= XPIV) Then
16314 0 : JLOW = JLOW + 1
16315 0 : XLOWT (JLOW) = XLOWT (ICRS)
16316 : Else
16317 0 : If (ICRS >= IFIN) Exit
16318 : End If
16319 : End Do
16320 : End If
16321 : Else
16322 0 : Do ICRS = 1, IFIN
16323 0 : If (XLOWT(ICRS) > XPIV) Then
16324 0 : JHIG = JHIG + 1
16325 0 : XHIGT (JHIG) = XLOWT (ICRS)
16326 : Else
16327 0 : JLOW = JLOW + 1
16328 0 : XLOWT (JLOW) = XLOWT (ICRS)
16329 0 : If (JLOW >= INTH) Exit
16330 : End If
16331 : End Do
16332 : !
16333 0 : Do ICRS = ICRS + 1, IFIN
16334 0 : If (XLOWT(ICRS) <= XPIV) Then
16335 0 : JLOW = JLOW + 1
16336 0 : XLOWT (JLOW) = XLOWT (ICRS)
16337 : End If
16338 : End Do
16339 : End If
16340 : !
16341 : End Select
16342 : !
16343 : End Do
16344 : !
16345 : ! Now, we only need to find maximum of the 1:INTH set
16346 : !
16347 0 : VALNTH = MAXVAL (XLOWT (1 : INTH))
16348 : Return
16349 : !
16350 : !
16351 0 : End Function R_valnth
16352 :
16353 0 : Function I_valnth (XDONT, NORD) Result (valnth)
16354 : ! Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
16355 : ! __________________________________________________________
16356 : ! This routine uses a pivoting strategy such as the one of
16357 : ! finding the median based on the quicksort algorithm, but
16358 : ! we skew the pivot choice to try to bring it to NORD as
16359 : ! fast as possible. It uses 2 temporary arrays, where it
16360 : ! stores the indices of the values smaller than the pivot
16361 : ! (ILOWT), and the indices of values larger than the pivot
16362 : ! that we might still need later on (IHIGT). It iterates
16363 : ! until it can bring the number of values in ILOWT to
16364 : ! exactly NORD, and then finds the maximum of this set.
16365 : ! Michel Olagnon - Aug. 2000
16366 : ! __________________________________________________________
16367 : ! __________________________________________________________
16368 : Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
16369 : Integer(kind = i4) :: valnth
16370 : Integer(kind = i4), Intent (In) :: NORD
16371 : ! __________________________________________________________
16372 0 : Integer(kind = i4), Dimension (SIZE(XDONT)) :: XLOWT, XHIGT
16373 : Integer(kind = i4) :: XPIV, XWRK, XWRK1, XWRK2, XWRK3, XMIN, XMAX
16374 : !
16375 : Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG
16376 : Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
16377 : Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
16378 : !
16379 0 : NDON = SIZE (XDONT)
16380 0 : INTH = MAX (MIN (NORD, NDON), 1)
16381 : !
16382 : ! First loop is used to fill-in XLOWT, XHIGT at the same time
16383 : !
16384 0 : If (NDON < 2) Then
16385 0 : If (INTH == 1) VALNTH = XDONT (1)
16386 0 : Return
16387 : End If
16388 : !
16389 : ! One chooses a pivot, best estimate possible to put fractile near
16390 : ! mid-point of the set of low values.
16391 : !
16392 0 : If (XDONT(2) < XDONT(1)) Then
16393 0 : XLOWT (1) = XDONT(2)
16394 0 : XHIGT (1) = XDONT(1)
16395 : Else
16396 0 : XLOWT (1) = XDONT(1)
16397 0 : XHIGT (1) = XDONT(2)
16398 : End If
16399 : !
16400 0 : If (NDON < 3) Then
16401 0 : If (INTH == 1) VALNTH = XLOWT (1)
16402 0 : If (INTH == 2) VALNTH = XHIGT (1)
16403 0 : Return
16404 : End If
16405 : !
16406 0 : If (XDONT(3) < XHIGT(1)) Then
16407 0 : XHIGT (2) = XHIGT (1)
16408 0 : If (XDONT(3) < XLOWT(1)) Then
16409 0 : XHIGT (1) = XLOWT (1)
16410 0 : XLOWT (1) = XDONT(3)
16411 : Else
16412 0 : XHIGT (1) = XDONT(3)
16413 : End If
16414 : Else
16415 0 : XHIGT (2) = XDONT(3)
16416 : End If
16417 : !
16418 0 : If (NDON < 4) Then
16419 0 : If (INTH == 1) Then
16420 0 : VALNTH = XLOWT (1)
16421 : Else
16422 0 : VALNTH = XHIGT (INTH - 1)
16423 : End If
16424 0 : Return
16425 : End If
16426 : !
16427 0 : If (XDONT(NDON) < XHIGT(1)) Then
16428 0 : XHIGT (3) = XHIGT (2)
16429 0 : XHIGT (2) = XHIGT (1)
16430 0 : If (XDONT(NDON) < XLOWT(1)) Then
16431 0 : XHIGT (1) = XLOWT (1)
16432 0 : XLOWT (1) = XDONT(NDON)
16433 : Else
16434 0 : XHIGT (1) = XDONT(NDON)
16435 : End If
16436 : Else
16437 0 : XHIGT (3) = XDONT(NDON)
16438 : End If
16439 : !
16440 0 : If (NDON < 5) Then
16441 0 : If (INTH == 1) Then
16442 0 : VALNTH = XLOWT (1)
16443 : Else
16444 0 : VALNTH = XHIGT (INTH - 1)
16445 : End If
16446 0 : Return
16447 : End If
16448 : !
16449 :
16450 0 : JLOW = 1
16451 0 : JHIG = 3
16452 0 : XPIV = XLOWT(1) + INT(REAL(2 * INTH, sp) / REAL(NDON + INTH, sp), i4) * (XHIGT(3) - XLOWT(1))
16453 0 : If (XPIV >= XHIGT(1)) Then
16454 : XPIV = XLOWT(1) + INT(REAL(2 * INTH, sp) / REAL(NDON + INTH, sp), i4) * &
16455 0 : (XHIGT(2) - XLOWT(1))
16456 0 : If (XPIV >= XHIGT(1)) &
16457 : XPIV = XLOWT(1) + INT(REAL(2 * INTH, sp) / REAL(NDON + INTH, sp), i4) * &
16458 0 : (XHIGT(1) - XLOWT(1))
16459 : End If
16460 : !
16461 : ! One puts values > pivot in the end and those <= pivot
16462 : ! at the beginning. This is split in 2 cases, so that
16463 : ! we can skip the loop test a number of times.
16464 : ! As we are also filling in the work arrays at the same time
16465 : ! we stop filling in the XHIGT array as soon as we have more
16466 : ! than enough values in XLOWT.
16467 : !
16468 : !
16469 0 : If (XDONT(NDON) > XPIV) Then
16470 : ICRS = 3
16471 : Do
16472 0 : ICRS = ICRS + 1
16473 0 : If (XDONT(ICRS) > XPIV) Then
16474 0 : If (ICRS >= NDON) Exit
16475 0 : JHIG = JHIG + 1
16476 0 : XHIGT (JHIG) = XDONT(ICRS)
16477 : Else
16478 0 : JLOW = JLOW + 1
16479 0 : XLOWT (JLOW) = XDONT(ICRS)
16480 0 : If (JLOW >= INTH) Exit
16481 : End If
16482 : End Do
16483 : !
16484 : ! One restricts further processing because it is no use
16485 : ! to store more high values
16486 : !
16487 0 : If (ICRS < NDON - 1) Then
16488 : Do
16489 0 : ICRS = ICRS + 1
16490 0 : If (XDONT(ICRS) <= XPIV) Then
16491 0 : JLOW = JLOW + 1
16492 0 : XLOWT (JLOW) = XDONT(ICRS)
16493 0 : Else If (ICRS >= NDON) Then
16494 : Exit
16495 : End If
16496 : End Do
16497 : End If
16498 : !
16499 : !
16500 : Else
16501 : !
16502 : ! Same as above, but this is not as easy to optimize, so the
16503 : ! DO-loop is kept
16504 : !
16505 0 : Do ICRS = 4, NDON - 1
16506 0 : If (XDONT(ICRS) > XPIV) Then
16507 0 : JHIG = JHIG + 1
16508 0 : XHIGT (JHIG) = XDONT(ICRS)
16509 : Else
16510 0 : JLOW = JLOW + 1
16511 0 : XLOWT (JLOW) = XDONT(ICRS)
16512 0 : If (JLOW >= INTH) Exit
16513 : End If
16514 : End Do
16515 : !
16516 0 : If (ICRS < NDON - 1) Then
16517 : Do
16518 0 : ICRS = ICRS + 1
16519 0 : If (XDONT(ICRS) <= XPIV) Then
16520 0 : If (ICRS >= NDON) Exit
16521 0 : JLOW = JLOW + 1
16522 0 : XLOWT (JLOW) = XDONT(ICRS)
16523 : End If
16524 : End Do
16525 : End If
16526 : End If
16527 : !
16528 : JLM2 = 0
16529 : JLM1 = 0
16530 : JHM2 = 0
16531 : JHM1 = 0
16532 : Do
16533 0 : If (JLM2 == JLOW .And. JHM2 == JHIG) Then
16534 : !
16535 : ! We are oscillating. Perturbate by bringing JLOW closer by one
16536 : ! to INTH
16537 : !
16538 0 : If (INTH > JLOW) Then
16539 0 : XMIN = XHIGT(1)
16540 0 : IHIG = 1
16541 0 : Do ICRS = 2, JHIG
16542 0 : If (XHIGT(ICRS) < XMIN) Then
16543 0 : XMIN = XHIGT(ICRS)
16544 0 : IHIG = ICRS
16545 : End If
16546 : End Do
16547 : !
16548 0 : JLOW = JLOW + 1
16549 0 : XLOWT (JLOW) = XHIGT (IHIG)
16550 0 : XHIGT (IHIG) = XHIGT (JHIG)
16551 0 : JHIG = JHIG - 1
16552 : Else
16553 :
16554 0 : XMAX = XLOWT (JLOW)
16555 0 : JLOW = JLOW - 1
16556 0 : Do ICRS = 1, JLOW
16557 0 : If (XLOWT(ICRS) > XMAX) Then
16558 0 : XWRK = XMAX
16559 0 : XMAX = XLOWT(ICRS)
16560 0 : XLOWT (ICRS) = XWRK
16561 : End If
16562 : End Do
16563 : End If
16564 : End If
16565 0 : JLM2 = JLM1
16566 0 : JLM1 = JLOW
16567 0 : JHM2 = JHM1
16568 0 : JHM1 = JHIG
16569 : !
16570 : ! We try to bring the number of values in the low values set
16571 : ! closer to INTH.
16572 : !
16573 0 : Select Case (INTH - JLOW)
16574 : Case (2 :)
16575 : !
16576 : ! Not enough values in low part, at least 2 are missing
16577 : !
16578 0 : INTH = INTH - JLOW
16579 0 : JLOW = 0
16580 : Select Case (JHIG)
16581 : !!!!! CASE DEFAULT
16582 : !!!!! write (unit=*,fmt=*) "Assertion failed"
16583 : !!!!! STOP
16584 : !
16585 : ! We make a special case when we have so few values in
16586 : ! the high values set that it is bad performance to choose a pivot
16587 : ! and apply the general algorithm.
16588 : !
16589 : Case (2)
16590 0 : If (XHIGT(1) <= XHIGT(2)) Then
16591 0 : JLOW = JLOW + 1
16592 0 : XLOWT (JLOW) = XHIGT (1)
16593 0 : JLOW = JLOW + 1
16594 0 : XLOWT (JLOW) = XHIGT (2)
16595 : Else
16596 0 : JLOW = JLOW + 1
16597 0 : XLOWT (JLOW) = XHIGT (2)
16598 0 : JLOW = JLOW + 1
16599 0 : XLOWT (JLOW) = XHIGT (1)
16600 : End If
16601 : Exit
16602 : !
16603 : Case (3)
16604 : !
16605 : !
16606 0 : XWRK1 = XHIGT (1)
16607 0 : XWRK2 = XHIGT (2)
16608 0 : XWRK3 = XHIGT (3)
16609 0 : If (XWRK2 < XWRK1) Then
16610 0 : XHIGT (1) = XWRK2
16611 0 : XHIGT (2) = XWRK1
16612 0 : XWRK2 = XWRK1
16613 : End If
16614 0 : If (XWRK2 > XWRK3) Then
16615 0 : XHIGT (3) = XWRK2
16616 0 : XHIGT (2) = XWRK3
16617 0 : XWRK2 = XWRK3
16618 0 : If (XWRK2 < XHIGT(1)) Then
16619 0 : XHIGT (2) = XHIGT (1)
16620 0 : XHIGT (1) = XWRK2
16621 : End If
16622 : End If
16623 : JHIG = 0
16624 0 : Do ICRS = JLOW + 1, INTH
16625 0 : JHIG = JHIG + 1
16626 0 : XLOWT (ICRS) = XHIGT (JHIG)
16627 : End Do
16628 0 : JLOW = INTH
16629 : Exit
16630 : !
16631 : Case (4 :)
16632 : !
16633 : !
16634 0 : IFIN = JHIG
16635 : !
16636 : ! One chooses a pivot from the 2 first values and the last one.
16637 : ! This should ensure sufficient renewal between iterations to
16638 : ! avoid worst case behavior effects.
16639 : !
16640 0 : XWRK1 = XHIGT (1)
16641 0 : XWRK2 = XHIGT (2)
16642 0 : XWRK3 = XHIGT (IFIN)
16643 0 : If (XWRK2 < XWRK1) Then
16644 0 : XHIGT (1) = XWRK2
16645 0 : XHIGT (2) = XWRK1
16646 0 : XWRK2 = XWRK1
16647 : End If
16648 0 : If (XWRK2 > XWRK3) Then
16649 0 : XHIGT (IFIN) = XWRK2
16650 0 : XHIGT (2) = XWRK3
16651 0 : XWRK2 = XWRK3
16652 0 : If (XWRK2 < XHIGT(1)) Then
16653 0 : XHIGT (2) = XHIGT (1)
16654 0 : XHIGT (1) = XWRK2
16655 : End If
16656 : End If
16657 : !
16658 0 : XWRK1 = XHIGT (1)
16659 0 : JLOW = JLOW + 1
16660 0 : XLOWT (JLOW) = XWRK1
16661 0 : XPIV = XWRK1 + (XHIGT(IFIN) - XWRK1) / 2
16662 : !
16663 : ! One takes values <= pivot to XLOWT
16664 : ! Again, 2 parts, one where we take care of the remaining
16665 : ! high values because we might still need them, and the
16666 : ! other when we know that we will have more than enough
16667 : ! low values in the end.
16668 : !
16669 0 : JHIG = 0
16670 0 : Do ICRS = 2, IFIN
16671 0 : If (XHIGT(ICRS) <= XPIV) Then
16672 0 : JLOW = JLOW + 1
16673 0 : XLOWT (JLOW) = XHIGT (ICRS)
16674 0 : If (JLOW >= INTH) Exit
16675 : Else
16676 0 : JHIG = JHIG + 1
16677 0 : XHIGT (JHIG) = XHIGT (ICRS)
16678 : End If
16679 : End Do
16680 : !
16681 0 : Do ICRS = ICRS + 1, IFIN
16682 0 : If (XHIGT(ICRS) <= XPIV) Then
16683 0 : JLOW = JLOW + 1
16684 0 : XLOWT (JLOW) = XHIGT (ICRS)
16685 : End If
16686 : End Do
16687 : End Select
16688 : !
16689 : !
16690 : Case (1)
16691 : !
16692 : ! Only 1 value is missing in low part
16693 : !
16694 0 : XMIN = XHIGT(1)
16695 0 : IHIG = 1
16696 0 : Do ICRS = 2, JHIG
16697 0 : If (XHIGT(ICRS) < XMIN) Then
16698 0 : XMIN = XHIGT(ICRS)
16699 0 : IHIG = ICRS
16700 : End If
16701 : End Do
16702 : !
16703 0 : VALNTH = XHIGT (IHIG)
16704 0 : Return
16705 : !
16706 : !
16707 : Case (0)
16708 : !
16709 : ! Low part is exactly what we want
16710 : !
16711 : Exit
16712 : !
16713 : !
16714 : Case (-5 : -1)
16715 : !
16716 : ! Only few values too many in low part
16717 : !
16718 0 : XHIGT (1) = XLOWT (1)
16719 0 : ILOW = 1 + INTH - JLOW
16720 0 : Do ICRS = 2, INTH
16721 0 : XWRK = XLOWT (ICRS)
16722 0 : Do IDCR = ICRS - 1, MAX (1, ILOW), - 1
16723 0 : If (XWRK < XHIGT(IDCR)) Then
16724 0 : XHIGT (IDCR + 1) = XHIGT (IDCR)
16725 : Else
16726 : Exit
16727 : End If
16728 : End Do
16729 0 : XHIGT (IDCR + 1) = XWRK
16730 0 : ILOW = ILOW + 1
16731 : End Do
16732 : !
16733 0 : XWRK1 = XHIGT(INTH)
16734 0 : ILOW = 2 * INTH - JLOW
16735 0 : Do ICRS = INTH + 1, JLOW
16736 0 : If (XLOWT (ICRS) < XWRK1) Then
16737 0 : XWRK = XLOWT (ICRS)
16738 0 : Do IDCR = INTH - 1, MAX (1, ILOW), - 1
16739 0 : If (XWRK >= XHIGT(IDCR)) Exit
16740 0 : XHIGT (IDCR + 1) = XHIGT (IDCR)
16741 : End Do
16742 0 : XHIGT (IDCR + 1) = XLOWT (ICRS)
16743 0 : XWRK1 = XHIGT(INTH)
16744 : End If
16745 0 : ILOW = ILOW + 1
16746 : End Do
16747 : !
16748 0 : VALNTH = XHIGT(INTH)
16749 0 : Return
16750 : !
16751 : !
16752 : Case (: -6)
16753 : !
16754 : ! last case: too many values in low part
16755 : !
16756 :
16757 0 : IMIL = (JLOW + 1) / 2
16758 0 : IFIN = JLOW
16759 : !
16760 : ! One chooses a pivot from 1st, last, and middle values
16761 : !
16762 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
16763 0 : XWRK = XLOWT (1)
16764 0 : XLOWT (1) = XLOWT (IMIL)
16765 0 : XLOWT (IMIL) = XWRK
16766 : End If
16767 0 : If (XLOWT(IMIL) > XLOWT(IFIN)) Then
16768 0 : XWRK = XLOWT (IFIN)
16769 0 : XLOWT (IFIN) = XLOWT (IMIL)
16770 0 : XLOWT (IMIL) = XWRK
16771 0 : If (XLOWT(IMIL) < XLOWT(1)) Then
16772 0 : XWRK = XLOWT (1)
16773 0 : XLOWT (1) = XLOWT (IMIL)
16774 0 : XLOWT (IMIL) = XWRK
16775 : End If
16776 : End If
16777 0 : If (IFIN <= 3) Exit
16778 : !
16779 : XPIV = XLOWT(1) + INT(REAL(INTH, sp) / REAL(JLOW + INTH, sp), i4) * &
16780 0 : (XLOWT(IFIN) - XLOWT(1))
16781 :
16782 : !
16783 : ! One takes values > XPIV to XHIGT
16784 : !
16785 0 : JHIG = 0
16786 0 : JLOW = 0
16787 : !
16788 0 : If (XLOWT(IFIN) > XPIV) Then
16789 : ICRS = 0
16790 : Do
16791 0 : ICRS = ICRS + 1
16792 0 : If (XLOWT(ICRS) > XPIV) Then
16793 0 : JHIG = JHIG + 1
16794 0 : XHIGT (JHIG) = XLOWT (ICRS)
16795 0 : If (ICRS >= IFIN) Exit
16796 : Else
16797 0 : JLOW = JLOW + 1
16798 0 : XLOWT (JLOW) = XLOWT (ICRS)
16799 0 : If (JLOW >= INTH) Exit
16800 : End If
16801 : End Do
16802 : !
16803 0 : If (ICRS < IFIN) Then
16804 : Do
16805 0 : ICRS = ICRS + 1
16806 0 : If (XLOWT(ICRS) <= XPIV) Then
16807 0 : JLOW = JLOW + 1
16808 0 : XLOWT (JLOW) = XLOWT (ICRS)
16809 : Else
16810 0 : If (ICRS >= IFIN) Exit
16811 : End If
16812 : End Do
16813 : End If
16814 : Else
16815 0 : Do ICRS = 1, IFIN
16816 0 : If (XLOWT(ICRS) > XPIV) Then
16817 0 : JHIG = JHIG + 1
16818 0 : XHIGT (JHIG) = XLOWT (ICRS)
16819 : Else
16820 0 : JLOW = JLOW + 1
16821 0 : XLOWT (JLOW) = XLOWT (ICRS)
16822 0 : If (JLOW >= INTH) Exit
16823 : End If
16824 : End Do
16825 : !
16826 0 : Do ICRS = ICRS + 1, IFIN
16827 0 : If (XLOWT(ICRS) <= XPIV) Then
16828 0 : JLOW = JLOW + 1
16829 0 : XLOWT (JLOW) = XLOWT (ICRS)
16830 : End If
16831 : End Do
16832 : End If
16833 : !
16834 : End Select
16835 : !
16836 : End Do
16837 : !
16838 : ! Now, we only need to find maximum of the 1:INTH set
16839 : !
16840 0 : VALNTH = MAXVAL (XLOWT (1 : INTH))
16841 : Return
16842 : !
16843 : !
16844 0 : End Function I_valnth
16845 :
16846 : END MODULE mo_orderpack
|
