mo_orderpack.f90

Go to the documentation of this file.

!> \file mo_orderpack.f90
!> \brief \copybrief mo_orderpack
!> \details \copydetails mo_orderpack
 
!> \brief Sort and ranking routines
!> \details
!! This module is the Orderpack 2.0 from Michel Olagnon.
!! It provides order and unconditional, unique, and partial
!! ranking, sorting, and permutation.
!!
!! <b> Unconditional ranking </b>
!!
!! \code{.f90} subroutine MRGRNK (XVALT, IMULT) \endcode
!!
!! Ranks array XVALT into index array IRNGT, using merge-sort.
!! For performance reasons, the first 2 passes are taken out of the
!! standard loop, and use dedicated coding.
!!
!! \code{.f90} subroutine MRGREF (XVALT, IRNGT) \endcode
!!
!! Ranks array XVALT into index array
!! IRNGT, using merge-sort. This version is not optimized for performance,
!! and is thus not as difficult to read as the previous one.
!!
!! <b> Partial ranking </b>
!!
!! \code{.f90} subroutine RNKPAR (XVALT, IRNGT, NORD) \endcode
!!
!! Ranks partially XVALT by IRNGT,
!! up to order NORD (refined for speed). This routine uses a pivoting
!! strategy such as the one of finding the median based on the quicksort
!! algorithm, but we skew the pivot choice to try to bring it to NORD as
!! fast as possible. It uses 2 temporary arrays, one where it stores the
!! indices of the values smaller than the pivot, and the other for the
!! indices of values larger than the pivot that we might still need later
!! on. It iterates until it can bring the number of values in ILOWT to
!! exactly NORD, and then uses an insertion sort to rank this set, since
!! it is supposedly small.
!!
!! \code{.f90} subroutine RAPKNR (XVALT, IRNGT, NORD) \endcode
!!
!! Same as RNKPAR, but in
!! decreasing order (RAPKNR = RNKPAR spelt backwards).
!!
!! \code{.f90} subroutine REFPAR (XVALT, IRNGT, NORD) \endcode
!!
!! Ranks partially XVALT by IRNGT,
!! up to order NORD This version is not optimized for performance, and is
!! thus not as difficult to read as some other ones. It uses a pivoting
!! strategy such as the one of finding the median based on the quicksort
!! algorithm. It uses a temporary array, where it stores the partially
!! ranked indices of the values. It iterates until it can bring the
!! number of values lower than the pivot to exactly NORD, and then uses
!! an insertion sort to rank this set, since it is supposedly small.
!!
!! \code{.f90} subroutine RINPAR (XVALT, IRNGT, NORD) \endcode
!!
!! Ranks partially XVALT by IRNGT,
!! up to order NORD This version is not optimized for performance, and is
!! thus not as difficult to read as some other ones. It uses insertion
!! sort, limiting insertion to the first NORD values. It does not use any
!! work array and is faster when NORD is very small (2-5), but worst case
!! behavior (intially inverse sorted) can easily happen. In many cases,
!! the refined quicksort method is faster.
!!
!! \code{.f90} integer function INDNTH (XVALT, NORD) \endcode
!!
!! Returns the index of the NORDth
!! value of XVALT (in increasing order) This routine uses a pivoting
!! strategy such as the one of finding the median based on the quicksort
!! algorithm, but we skew the pivot choice to try to bring it to NORD as
!! fast as possible. It uses 2 temporary arrays, one where it stores the
!! indices of the values smaller than the pivot, and the other for the
!! indices of values larger than the pivot that we might still need later
!! on. It iterates until it can bring the number of values in ILOWT to
!! exactly NORD, and then takes out the original index of the maximum
!! value in this set.
!!
!! \code{.f90} subroutine INDMED (XVALT, INDM) \endcode
!!
!! Returns the index of the median
!! (((Size(XVALT)+1))/2th value) of XVALT This routine uses the recursive
!! procedure described in Knuth, The Art of Computer Programming, vol. 3,
!! 5.3.3 - This procedure is linear in time, and does not require to be
!! able to interpolate in the set as the one used in INDNTH. It also has
!! better worst case behavior than INDNTH, but is about 10% slower in
!! average for random uniformly distributed values.
!!
!! Note that in Orderpack 1.0, this routine was a Function procedure, and
!! is now changed to a Subroutine.
!!
!! <b> Unique ranking </b>
!!
!! \code{.f90} subroutine UNIRNK (XVALT, IRNGT, NUNI) \endcode
!!
!! Ranks an array, removing
!! duplicate entries (uses merge sort).  The routine is similar to pure
!! merge-sort ranking, but on the last pass, it discards indices that
!! correspond to duplicate entries. For performance reasons, the first 2
!! passes are taken out of the standard loop, and use dedicated coding.
!!
!! \code{.f90} subroutine UNIPAR (XVALT, IRNGT, NORD) \endcode
!!
!! Ranks partially XVALT by IRNGT,
!! up to order NORD at most, removing duplicate entries This routine uses
!! a pivoting strategy such as the one of finding the median based on the
!! quicksort algorithm, but we skew the pivot choice to try to bring it
!! to NORD as quickly as possible. It uses 2 temporary arrays, one where
!! it stores the indices of the values smaller than the pivot, and the
!! other for the indices of values larger than the pivot that we might
!! still need later on. It iterates until it can bring the number of
!! values in ILOWT to exactly NORD, and then uses an insertion sort to
!! rank this set, since it is supposedly small. At all times, the NORD
!! first values in ILOWT correspond to distinct values of the input
!! array.
!!
!! \code{.f90} subroutine UNIINV (XVALT, IGOEST) \endcode
!!
!! Inverse ranking of an array, with
!! removal of duplicate entries The routine is similar to pure merge-sort
!! ranking, but on the last pass, it sets indices in IGOEST to the rank
!! of the original value in an ordered set with duplicates removed. For
!! performance reasons, the first 2 passes are taken out of the standard
!! loop, and use dedicated coding.
!!
!! \code{.f90} subroutine MULCNT (XVALT, IMULT) \endcode
!!
!! Gives, for each array value, its
!! multiplicity The number of times that a value appears in the array is
!! computed by using inverse ranking, counting for each rank the number
!! of values that ``collide'' to this rank, and returning this sum to the
!! locations in the original set. Uses subroutine UNIINV.
!!
!! <b> Random permutation: an interesting use of ranking </b>
!!
!! A variation of the following problem was raised on the internet
!! sci.math.num-analysis news group: Given an array, I would like to find
!! a random permutation of this array that I could control with a
!! "nearbyness" parameter so that elements stay close to their initial
!! locations. The "nearbyness" parameter ranges from 0 to 1, with 0
!! such that no element moves from its initial location, and 1 such that
!! the permutation is fully random.
!!
!! \code{.f90} subroutine CTRPER (XVALT, PCLS) \endcode
!!
!! Permute array XVALT randomly, but
!! leaving elements close to their initial locations The routine takes
!! the 1...size(XVALT) index array as real values, takes a combination of
!! these values and of random values as a perturbation of the index
!! array, and sorts the initial set according to the ranks of these
!! perturbated indices. The relative proportion of initial order and
!! random order is 1-PCLS / PCLS, thus when PCLS = 0, there is no change
!! in the order whereas the new order is fully random when PCLS = 1. Uses
!! subroutine MRGRNK.
!!
!! The above solution found another application when I was asked the
!! following question: I am given two arrays, representing parents'
!! incomes and their children's incomes, but I do not know which parents
!! correspond to which children. I know from an independent source the
!! value of the correlation coefficient between the incomes of the
!! parents and of their children. I would like to pair the elements of
!! these arrays so that the given correlation coefficient is attained,
!! i.e. to reconstruct a realistic dataset, though very likely not to be
!! the true one.
!!
!! \code{.f90} program GIVCOR \endcode
!!
!! Given two arrays of equal length of unordered values,
!! find a "matching value" in the second array for each value in the
!! first so that the global correlation coefficient reaches exactly a
!! given target The routine first sorts the two arrays, so as to get the
!! match of maximum possible correlation. It then iterates, applying the
!! random permutation algorithm of controlled disorder ctrper to the
!! second array. When the resulting correlation goes beyond (lower than)
!! the target correlation, one steps back and reduces the disorder
!! parameter of the permutation. When the resulting correlation lies
!! between the current one and the target, one replaces the array with
!! the newly permuted one. When the resulting correlation increases from
!! the current value, one increases the disorder parameter. That way, the
!! target correlation is approached from above, by a controlled increase
!! in randomness. Since full randomness leads to zero correlation, the
!! iterations meet the desired coefficient at some point. It may be noted
!! that there could be some cases when one would get stuck in a sort of
!! local minimum, where local perturbations cannot further reduce the
!! correlation and where global ones lead to overpass the target. It
!! seems easier to restart the program with a different seed when this
!! occurs than to design an avoidance scheme. Also, should a negative
!! correlation be desired, the program should be modified to start with
!! one array in reverse order with respect to the other, i.e. coorelation
!! as close to -1 as possible.
!!
!! <b> Full sorting </b>
!!
!! \code{.f90} subroutine INSSOR (XVALT) \endcode
!!
!! Sorts XVALT into increasing order (Insertion
!! sort) This subroutine uses insertion sort. It does not use any work
!! array and is faster when XVALT is of very small size (< 20), or
!! already almost sorted, but worst case behavior (intially inverse
!! sorted) can easily happen. In most cases, the quicksort or merge sort
!! method is faster.
!!
!! \code{.f90} subroutine REFSOR (XVALT) \endcode
!!
!! Sorts XVALT into increasing order (Quick
!! sort) This version is not optimized for performance, and is thus not
!! as difficult to read as some other ones. This subroutine uses
!! quicksort in a recursive implementation, and insertion sort for the
!! last steps with small subsets. It does not use any work array
!!
!! <b> Partial sorting </b>
!!
!! \code{.f90} subroutine INSPAR (XVALT, NORD) \endcode
!!
!! Sorts partially XVALT, bringing the
!! NORD lowest values at the begining of the array.  This subroutine uses
!! insertion sort, limiting insertion to the first NORD values. It does
!! not use any work array and is faster when NORD is very small (2-5),
!! but worst case behavior can happen fairly probably (initially inverse
!! sorted). In many cases, the refined quicksort method is faster.
!!
!! \code{.f90} function FNDNTH (XVALT, NORD) \endcode
!!
!! Finds out and returns the NORDth value
!! in XVALT (ascending order) This subroutine uses insertion sort,
!! limiting insertion to the first NORD values, and even less when one
!! can know that the value that is considered will not be the NORDth. It
!! uses only a work array of size NORD and is faster when NORD is very
!! small (2-5), but worst case behavior can happen fairly probably
!! (initially inverse sorted). In many cases, the refined quicksort
!! method implemented by VALNTH / INDNTH is faster, though much more
!! difficult to read and understand.
!!
!! \code{.f90} function VALNTH (XVALT, NORD) \endcode
!!
!! Finds out and returns the NORDth value
!! in XVALT (ascending order) This subroutine simply calls INDNTH.
!!
!! \code{.f90} function VALMED (XVALT) \endcode
!!
!! Finds out and returns the median(((Size(XVALT)+1))/2th value) of XVALT This routine uses the recursive
!! procedure described in Knuth, The Art of Computer Programming, vol. 3,
!! 5.3.3 - This procedure is linear in time, and does not require to be
!! able to interpolate in the set as the one used in VALNTH/INDNTH. It
!! also has better worst case behavior than VALNTH/INDNTH, and is about
!! 20% faster in average for random uniformly distributed values.
!!
!! \code{.f90} function OMEDIAN (XVALT) \endcode
!!
!! It is a modified version of VALMED that
!! provides the average between the two middle values in the case
!! Size(XVALT) is even.
!!
!! <b> Unique sorting </b>
!!
!! \code{.f90} subroutine UNISTA (XVALT, NUNI) \endcode
!!
!! Removes duplicates from an array This
!! subroutine uses merge sort unique inverse ranking. It leaves in the
!! initial set only those entries that are unique, packing the array, and
!! leaving the order of the retained values unchanged.
!> \authors Michel Olagnon
!> \date 2000-2012
!> \changelog
!! - Matthias Cuntz, Apr 2014
!!   - adapted to UFZ library
!!   - one module, cleaned all warnings
!! - Juliane Mai,    Nov 2014
!!   - replaced floating comparison by ne(), eq(), etc. from mo_utils
!! - Matthias Cuntz, Jul 2015
!!   - median -> omedian
!> \copyright Copyright 2005-\today, the CHS Developers, Sabine Attinger: All rights reserved.
!! FORCES is released under the LGPLv3+ license \license_note
MODULE mo_orderpack
 
  USE mo_kind, ONLY : i4, sp, dp
  USE mo_utils, ONLY : ne, eq, le
 
  IMPLICIT NONE
 
  ! Public routines
  public :: sort       ! alias for refsor
  public :: sort_index ! wrapper for mrgrnk
 
  public :: ctrper
  public :: fndnth
  public :: indmed
  public :: indnth
  public :: inspar
  public :: inssor
  public :: omedian
  public :: mrgref
  public :: mrgrnk
  public :: mulcnt
  public :: rapknr
  public :: refpar
  public :: refsor
  public :: rinpar
  public :: rnkpar
  public :: uniinv
  public :: unipar
  public :: unirnk
  public :: unista
  public :: valmed
  public :: valnth
 
  ! aliases/wrapper
 
  !> \brief Sorts the input array in ascending order.
  !> \param[in,out] "real(sp/dp) :: arr(:)"     On input:  unsorted 1D-array\n
  !!                                            On output: ascendingly sorted input array
  interface sort
    module procedure d_refsor, r_refsor, i_refsor, c_refsor
  end interface sort
 
  !> \brief Gives the indeces that would sort an array in ascending order.
  !> \param[in] "real(sp/dp) :: arr(:)"     Unsorted 1D-array
  !> \return integer(i4) :: indices(:) &mdash; Indices that would sort arr in ascending order
  interface sort_index
    module procedure sort_index_dp, sort_index_sp, sort_index_i4
  end interface sort_index
 
  !>    \brief Random permutation ranking.
 
  !>    \details
  !!    Permute array XVALT randomly, but
  !!    leaving elements close to their initial locations The routine takes
  !!    the 1...size(XVALT) index array as real values, takes a combination of
  !!    these values and of random values as a perturbation of the index
  !!    array, and sorts the initial set according to the ranks of these
  !!    perturbated indices. The relative proportion of initial order and
  !!    random order is 1-PCLS / PCLS, thus when PCLS = 0, there is no change
  !!    in the order whereas the new order is fully random when PCLS = 1. Uses
  !!    subroutine MRGRNK.
  !!
  !!    The above solution found another application when I was asked the
  !!    following question: I am given two arrays, representing parents'
  !!    incomes and their children's incomes, but I do not know which parents
  !!    correspond to which children. I know from an independent source the
  !!    value of the correlation coefficient between the incomes of the
  !!    parents and of their children. I would like to pair the elements of
  !!    these arrays so that the given correlation coefficient is attained,
  !!    i.e. to reconstruct a realistic dataset, though very likely not to be
  !!    the true one.
 
  !>    \param[inout]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be randomly permuted.
  !>    \param[in]    "integer(i4)/real(sp,dp) :: PCLS" Nearbyness of permutation.
 
  interface ctrper
    module procedure d_ctrper, r_ctrper, i_ctrper
  end interface ctrper
 
  !>    \brief Find N-th value in array from insertion sort
 
  !>    \details
  !!    Finds out and returns the NORDth value
  !!    in XVALT (ascending order). This subroutine uses insertion sort,
  !!    limiting insertion to the first NORD values, and even less when one
  !!    can know that the value that is considered will not be the NORDth. It
  !!    uses only a work array of size NORD and is faster when NORD is very
  !!    small (2-5), but worst case behavior can happen fairly probably
  !!    (initially inverse sorted). In many cases, the refined quicksort
  !!    method implemented by VALNTH / INDNTH is faster, though much more
  !!    difficult to read and understand.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[in]  "integer(i4) :: NORD" Number of ranked elements.
  !>    \retval     "integer(i4)/real(sp,dp) :: FNDNTH" Value of NORDth rank.
 
  interface fndnth
    module procedure d_fndnth, r_fndnth, i_fndnth
  end interface fndnth
 
  !>    \brief Median index of skewed-pivot with quicksort ranking.
 
  !>    \details
  !!    Returns the index of the median
  !!    `(((Size(XVALT)+1))/2th value)` of XVALT This routine uses the recursive
  !!    procedure described in Knuth, The Art of Computer Programming, vol. 3,
  !!    5.3.3 - This procedure is linear in time, and does not require to be
  !!    able to interpolate in the set as the one used in INDNTH. It also has
  !!    better worst case behavior than INDNTH, but is about 10% slower in
  !!    average for random uniformly distributed values.\n
  !!    Note that in Orderpack 1.0, this routine was a Function procedure, and
  !!    is now changed to a Subroutine.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[out]     "integer(i4) :: INDM" Index of Median.
 
  interface indmed
    module procedure d_indmed, r_indmed, i_indmed
  end interface indmed
 
  !>    \brief Nth index of skewed-pivot with quicksort ranking.
 
  !>    \details
  !!    Returns the index of the NORDth
  !!    value of XVALT (in increasing order). This routine uses a pivoting
  !!    strategy such as the one of finding the median based on the quicksort
  !!    algorithm, but we skew the pivot choice to try to bring it to NORD as
  !!    fast as possible. It uses 2 temporary arrays, one where it stores the
  !!    indices of the values smaller than the pivot, and the other for the
  !!    indices of values larger than the pivot that we might still need later
  !!    on. It iterates until it can bring the number of values in ILOWT to
  !!    exactly NORD, and then takes out the original index of the maximum
  !!    value in this set.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[in]  "integer(i4) :: NORD" Number of ranked elements.
  !>    \retval     "integer(i4) :: INDNTH" Index of NORDth rank.
 
  interface indnth
    module procedure d_indnth, r_indnth, i_indnth
  end interface indnth
 
  !>    \brief Partial insertion sort ranking,
 
  !>    \details
  !!    Sorts partially XVALT, bringing the
  !!    NORD lowest values at the begining of the array.  This subroutine uses
  !!    insertion sort, limiting insertion to the first NORD values. It does
  !!    not use any work array and is faster when NORD is very small (2-5),
  !!    but worst case behavior can happen fairly probably (initially inverse
  !!    sorted). In many cases, the refined quicksort method is faster.
 
  !>    \param[inout]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[in]  "integer(i4) :: NORD" Number of ranked elements from beginning of array.
 
  interface inspar
    module procedure d_inspar, r_inspar, i_inspar
  end interface inspar
 
  !>    \brief  Insertion sort ranking
 
  !>    \details
  !!    Sorts XVALT into increasing order (Insertion
  !!    sort) This subroutine uses insertion sort. It does not use any work
  !!    array and is faster when XVALT is of very small size (< 20), or
  !!    already almost sorted, but worst case behavior (intially inverse
  !!    sorted) can easily happen. In most cases, the quicksort or merge sort
  !!    method is faster.
 
  !>    \param[inout]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
 
  interface inssor
    module procedure d_inssor, r_inssor, i_inssor, c_inssor
  end interface inssor
 
  !>    \brief Find median value of array (case for even elements)
 
  !>    \details
  !!    It is a modified version of VALMED that
  !!    provides the average between the two middle values in the case
  !!    Size(XVALT) is even.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \retval     "integer(i4)/real(sp,dp) :: OMEDIAN" Value of median.
 
  interface omedian
    module procedure d_median, r_median, i_median
  end interface omedian
 
  !>    \brief Merge-sort ranking (unoptimized)
 
  !>    \details
  !!    Ranks array XVALT into index array
  !!    IRNGT, using merge-sort. This version is not optimized for performance,
  !!    and is thus not as difficult to read as the previous one.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \retval     "integer(i4), dimension(:) :: IRNGT" Index of rank.
 
  interface mrgref
    module procedure d_mrgref, r_mrgref, i_mrgref
  end interface mrgref
 
  !>    \brief Merge-sort ranking
 
  !>    \details
  !!    Ranks array XVALT into index array IRNGT, using merge-sort.\n
  !!    For performance reasons, the first 2 passes are taken out of the
  !!    standard loop, and use dedicated coding.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \retval     "integer(i4), dimension(:) :: IRNGT" Index of rank.
 
  interface mrgrnk
    module procedure d_mrgrnk, r_mrgrnk, i_mrgrnk, c_mrgrnk
  end interface mrgrnk
 
  !>    \brief  Multiplicity of array values.
 
  !>    \details
  !!    Gives, for each array value, its
  !!    multiplicity. The number of times that a value appears in the array is
  !!    computed by using inverse ranking, counting for each rank the number
  !!    of values that ``collide'' to this rank, and returning this sum to the
  !!    locations in the original set. Uses subroutine UNIINV.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[out] "integer(i4), dimension(:) :: IMULT" Multiplicity of array values.
 
 
  interface mulcnt
    module procedure d_mulcnt, r_mulcnt, i_mulcnt
  end interface mulcnt
 
  !>    \brief  Skewed-pivot with quicksort ranking (reversed).
 
  !>    \details
  !!    Same as `RNKPAR`, but in
  !!    decreasing order (RAPKNR = RNKPAR spelt backwards).
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[in]  "integer(i4) :: NORD" Number of ranked elements.
  !>    \retval     "integer(i4), dimension(:) :: IRNGT" Index of rank.
 
  interface rapknr
    module procedure d_rapknr, r_rapknr, i_rapknr
  end interface rapknr
 
  !>    \brief Skewed-pivot with quicksort ranking (unoptimized).
 
  !>    \details
  !!    Ranks partially XVALT by IRNGT,
  !!    up to order NORD. This version is not optimized for performance, and is
  !!    thus not as difficult to read as some other ones. It uses a pivoting
  !!    strategy such as the one of finding the median based on the quicksort
  !!    algorithm. It uses a temporary array, where it stores the partially
  !!    ranked indices of the values. It iterates until it can bring the
  !!    number of values lower than the pivot to exactly NORD, and then uses
  !!    an insertion sort to rank this set, since it is supposedly small.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[in]  "integer(i4) :: NORD" Number of ranked elements.
  !>    \retval     "integer(i4), dimension(:) :: IRNGT" Index of rank.
 
  interface refpar
    module procedure d_refpar, r_refpar, i_refpar
  end interface refpar
 
  !>    \brief  Quicksort ranking, with insertion sort at last step (unoptimized)
 
  !>    \details
  !!    Sorts XVALT into increasing order (Quick
  !!    sort). This version is not optimized for performance, and is thus not
  !!    as difficult to read as some other ones. This subroutine uses
  !!    quicksort in a recursive implementation, and insertion sort for the
  !!    last steps with small subsets. It does not use any work array
 
  !>    \param[inout]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
 
  interface refsor
    module procedure d_refsor, r_refsor, i_refsor, c_refsor
  end interface refsor
 
  !>    \brief Insertion sort ranking (unoptimized).
 
  !>    \details
  !!    Ranks partially XVALT by IRNGT,
  !!    up to order NORD This version is not optimized for performance, and is
  !!    thus not as difficult to read as some other ones. It uses insertion
  !!    sort, limiting insertion to the first NORD values. It does not use any
  !!    work array and is faster when NORD is very small (2-5), but worst case
  !!    behavior (intially inverse sorted) can easily happen. In many cases,
  !!    refined quicksort method is faster.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[in]  "integer(i4) :: NORD" Number of ranked elements.
  !>    \retval     "integer(i4), dimension(:) :: IRNGT" Index of rank.
 
  interface rinpar
    module procedure d_rinpar, r_rinpar, i_rinpar
  end interface rinpar
 
  !>    \brief  Skewed-pivot with quicksort ranking.
 
  !>    \details
  !!    Ranks partially XVALT by IRNGT,
  !!    up to order NORD (refined for speed). This routine uses a pivoting
  !!    strategy such as the one of finding the median based on the quicksort
  !!    algorithm, but we skew the pivot choice to try to bring it to NORD as
  !!    fast as possible. It uses 2 temporary arrays, one where it stores the
  !!    indices of the values smaller than the pivot, and the other for the
  !!    indices of values larger than the pivot that we might still need later
  !!    on. It iterates until it can bring the number of values in ILOWT to
  !!    exactly NORD, and then uses an insertion sort to rank this set, since
  !!    it is supposedly small.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[in]  "integer(i4) :: NORD" Number of ranked elements.
  !>    \retval     "integer(i4), dimension(:) :: IRNGT" Index of rank.
 
  interface rnkpar
    module procedure d_rnkpar, r_rnkpar, i_rnkpar
  end interface rnkpar
 
  !>    \brief Merge-sort ranking, with removal of duplicate entries (reversed).
 
  !>    \details
  !!    Inverse ranking of an array, with
  !!    removal of duplicate entries. The routine is similar to pure merge-sort
  !!    ranking, but on the last pass, it sets indices in IGOEST to the rank
  !!    of the original value in an ordered set with duplicates removed. For
  !!    performance reasons, the first 2 passes are taken out of the standard
  !!    loop, and use dedicated coding.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[out] "integer(i4), dimension(:) :: IGOEST" Index of rank.
 
  interface uniinv
    module procedure d_uniinv, r_uniinv, i_uniinv
  end interface uniinv
  interface nearless
    module procedure d_nearless, r_nearless, i_nearless
  end interface nearless
 
  !>    \brief Partial quicksort/insertion sort ranking, with removal of duplicate entries.
 
  !>    \details
  !!    Ranks partially XVALT by IRNGT,
  !!    up to order NORD at most, removing duplicate entries. This routine uses
  !!    a pivoting strategy such as the one of finding the median based on the
  !!    quicksort algorithm, but we skew the pivot choice to try to bring it
  !!    to NORD as quickly as possible. It uses 2 temporary arrays, one where
  !!    it stores the indices of the values smaller than the pivot, and the
  !!    other for the indices of values larger than the pivot that we might
  !!    still need later on. It iterates until it can bring the number of
  !!    values in ILOWT to exactly NORD, and then uses an insertion sort to
  !!    rank this set, since it is supposedly small. At all times, the NORD
  !!    first values in ILOWT correspond to distinct values of the input
  !!    array.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[in]  "integer(i4) :: NORD" Rank of quicksort ranking.
  !>    \param[out] "integer(i4), dimension(:) :: IRNGT" Index of rank.
 
  interface unipar
    module procedure d_unipar, r_unipar, i_unipar
  end interface unipar
 
  !>    \brief Merge-sort ranking, with removal of duplicate entries.
 
  !>    \details
  !!    Ranks an array, removing
  !!    duplicate entries (uses merge sort).  The routine is similar to pure
  !!    merge-sort ranking, but on the last pass, it discards indices that
  !!    correspond to duplicate entries. For performance reasons, the first 2
  !!    passes are taken out of the standard loop, and use dedicated coding.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[out]  "integer(i4) :: NUNI" Rank of last number after duplicates removed.
  !>    \param[out] "integer(i4), dimension(:) :: IRNGT" Index of rank.
 
  interface unirnk
    module procedure d_unirnk, r_unirnk, i_unirnk
  end interface unirnk
 
  !>    \brief  Merge-sort unique inverse ranking.
 
  !>    \details
  !!    Removes duplicates from an array This
  !!    subroutine uses merge sort unique inverse ranking. It leaves in the
  !!    initial set only those entries that are unique, packing the array, and
  !!    leaving the order of the retained values unchanged.
 
  !>    \param[inout]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[out]  "integer(i4) :: NUNI" Rank of last number after duplicates removed.
 
  interface unista
    module procedure d_unista, r_unista, i_unista
  end interface unista
 
  !>    \brief  Find median value of array
 
  !>    \details
  !!    Finds out and returns the median(((Size(XVALT)+1))/2th value) of XVALT This routine uses the recursive
  !!    procedure described in Knuth, The Art of Computer Programming, vol. 3,
  !!    5.3.3 - This procedure is linear in time, and does not require to be
  !!    able to interpolate in the set as the one used in VALNTH/INDNTH. It
  !!    also has better worst case behavior than VALNTH/INDNTH, and is about
  !!    20% faster in average for random uniformly distributed values.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \retval     "integer(i4)/real(sp,dp) :: VALMED" Value of median.
 
  interface valmed
    module procedure d_valmed, r_valmed, i_valmed
  end interface valmed
 
  !>    \brief  Find N-th value in array from quicksort
 
  !>    \details
  !!    Finds out and returns the NORDth value
  !!    in XVALT (ascending order). This subroutine simply calls INDNTH.
 
  !>    \param[in]  "integer(i4)/real(sp,dp), dimension(:) :: XVALT"  Array to be ranked.
  !>    \param[in]  "integer(i4) :: NORD" Number of ranked elements.
  !>    \retval     "integer(i4)/real(sp,dp) :: VALNTH" Value of NORDth rank.
 
  interface valnth
    module procedure d_valnth, r_valnth, i_valnth
  end interface valnth
 
  private :: r_ctrper, i_ctrper, d_ctrper
  private :: r_fndnth, i_fndnth, d_fndnth
  private :: r_indmed, i_indmed, d_indmed
  private :: r_indnth, i_indnth, d_indnth
  private :: r_inspar, i_inspar, d_inspar
  private :: r_inssor, i_inssor, d_inssor, c_inssor
  private :: r_median, i_median, d_median
  private :: r_mrgref, i_mrgref, d_mrgref
  private :: r_mrgrnk, i_mrgrnk, d_mrgrnk
  private :: r_mulcnt, i_mulcnt, d_mulcnt
  private :: r_nearless, i_nearless, d_nearless, nearless
  private :: r_rapknr, i_rapknr, d_rapknr
  private :: r_refpar, i_refpar, d_refpar
  private :: r_refsor, i_refsor, d_refsor, c_refsor
  private :: r_rinpar, i_rinpar, d_rinpar
  private :: r_rnkpar, i_rnkpar, d_rnkpar
  private :: r_subsor, i_subsor, d_subsor, c_subsor
  private :: r_uniinv, i_uniinv, d_uniinv
  private :: r_unipar, i_unipar, d_unipar
  private :: r_unirnk, i_unirnk, d_unirnk
  private :: r_unista, i_unista, d_unista
  private :: r_valmed, i_valmed, d_valmed
  private :: r_valnth, i_valnth, d_valnth
  private :: r_med, i_med, d_med
 
  PRIVATE
 
  Integer(kind = i4), Allocatable, Dimension(:), Save :: IDONT
 
CONTAINS
 
  ! ------------------------------------------------------------------
 
  FUNCTION sort_index_dp(arr)
 
    IMPLICIT NONE
 
    REAL(dp), DIMENSION(:), INTENT(IN) :: arr
    INTEGER(i4), DIMENSION(size(arr)) :: sort_index_dp
 
    call mrgrnk(arr, sort_index_dp)
 
  END FUNCTION sort_index_dp
 
  FUNCTION sort_index_sp(arr)
 
    IMPLICIT NONE
 
    REAL(sp), DIMENSION(:), INTENT(IN) :: arr
    INTEGER(i4), DIMENSION(size(arr)) :: sort_index_sp
 
    call mrgrnk(arr, sort_index_sp)
 
  END FUNCTION sort_index_sp
 
  FUNCTION sort_index_i4(arr)
 
    IMPLICIT NONE
 
    integer(i4), DIMENSION(:), INTENT(IN) :: arr
    INTEGER(i4), DIMENSION(size(arr)) :: sort_index_i4
 
    call mrgrnk(arr, sort_index_i4)
 
  END FUNCTION sort_index_i4
 
 
  ! ------------------------------------------------------------------
 
  Subroutine d_ctrper (XDONT, PCLS)
    !   Permute array XVALT randomly, but leaving elements close
    !   to their initial locations (nearbyness is controled by PCLS).
    ! _________________________________________________________________
    !   The routine takes the 1...size(XVALT) index array as real
    !   values, takes a combination of these values and of random
    !   values as a perturbation of the index array, and sorts the
    !   initial set according to the ranks of these perturbated indices.
    !   The relative proportion of initial order and random order
    !   is 1-PCLS / PCLS, thus when PCLS = 0, there is no change in
    !   the order whereas the new order is fully random when PCLS = 1.
    !   Michel Olagnon - May 2000.
    ! _________________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (InOut) :: xdont
    Real(kind = dp), Intent (In) :: pcls
    ! __________________________________________________________
    !
    Real(kind = dp), Dimension (Size(XDONT)) :: xindt
    Integer(kind = i4), Dimension (Size(XDONT)) :: JWRKT
    Real(kind = dp) :: pwrk
    Integer(kind = i4) :: I
    Real(kind = dp), Dimension (Size(XDONT)) :: ii
    !
    Call random_number (xindt(:))
    pwrk = min(max(0.0_dp, pcls), 1.0_dp)
    xindt = real(Size(xdont), dp) * xindt
    forall(i = 1 : size(xdont)) ii(i) = real(i, dp) ! for gnu compiler to be initialised
    xindt = pwrk * xindt + (1.0_dp - pwrk) * ii
    Call mrgrnk (xindt, jwrkt)
    xdont = xdont(jwrkt)
    !
  End Subroutine d_ctrper
 
  Subroutine r_ctrper (XDONT, PCLS)
    !   Permute array XVALT randomly, but leaving elements close
    !   to their initial locations (nearbyness is controled by PCLS).
    ! _________________________________________________________________
    !   The routine takes the 1...size(XVALT) index array as real
    !   values, takes a combination of these values and of random
    !   values as a perturbation of the index array, and sorts the
    !   initial set according to the ranks of these perturbated indices.
    !   The relative proportion of initial order and random order
    !   is 1-PCLS / PCLS, thus when PCLS = 0, there is no change in
    !   the order whereas the new order is fully random when PCLS = 1.
    !   Michel Olagnon - May 2000.
    ! _________________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (InOut) :: xdont
    Real(kind = sp), Intent (In) :: pcls
    ! __________________________________________________________
    !
    Real(kind = sp), Dimension (Size(XDONT)) :: xindt
    Integer(kind = i4), Dimension (Size(XDONT)) :: JWRKT
    Real(kind = sp) :: pwrk
    Integer(kind = i4) :: I
    Real(kind = sp), Dimension (Size(XDONT)) :: ii
    !
    Call random_number (xindt(:))
    pwrk = min(max(0.0, pcls), 1.0)
    xindt = real(Size(xdont), sp) * xindt
    forall(i = 1 : size(xdont)) ii(i) = real(i, sp) ! for gnu compiler to be initialised
    xindt = pwrk * xindt + (1.0 - pwrk) * ii
    Call mrgrnk (xindt, jwrkt)
    xdont = xdont(jwrkt)
    !
  End Subroutine r_ctrper
 
  Subroutine i_ctrper (XDONT, PCLS)
    !   Permute array XVALT randomly, but leaving elements close
    !   to their initial locations (nearbyness is controled by PCLS).
    ! _________________________________________________________________
    !   The routine takes the 1...size(XVALT) index array as real
    !   values, takes a combination of these values and of random
    !   values as a perturbation of the index array, and sorts the
    !   initial set according to the ranks of these perturbated indices.
    !   The relative proportion of initial order and random order
    !   is 1-PCLS / PCLS, thus when PCLS = 0, there is no change in
    !   the order whereas the new order is fully random when PCLS = 1.
    !   Michel Olagnon - May 2000.
    ! _________________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (InOut) :: XDONT
    Real(kind = sp), Intent (In) :: pcls
    ! __________________________________________________________
    !
    Real(kind = sp), Dimension (Size(XDONT)) :: xindt
    Integer(kind = i4), Dimension (Size(XDONT)) :: JWRKT
    Real(kind = sp) :: pwrk
    Integer(kind = i4) :: I
    Real(kind = sp), Dimension (Size(XDONT)) :: ii
    !
    Call random_number (xindt(:))
    pwrk = min(max(0.0, pcls), 1.0)
    xindt = real(Size(xdont), sp) * xindt
    forall(i = 1 : size(xdont)) ii(i) = real(i, sp) ! for gnu compiler to be initialised
    xindt = pwrk * xindt + (1.0 - pwrk) * ii
    Call mrgrnk(xindt, jwrkt)
    xdont = xdont(jwrkt)
    !
  End Subroutine i_ctrper
 
  Function d_fndnth (XDONT, NORD) Result (FNDNTH)
    !  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
    ! ______________________________________________________________________
    !  This subroutine uses insertion sort, limiting insertion
    !  to the first NORD values. It is faster when NORD is very small (2-5),
    !  and it requires only a workarray of size NORD and type of XDONT,
    !  but worst case behavior can happen fairly probably (initially inverse
    !  sorted). In many cases, the refined quicksort method is faster.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(Kind = dp), Dimension (:), Intent (In) :: xdont
    real(Kind = dp) :: fndnth
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    real(Kind = dp), Dimension (NORD) :: xwrkt
    real(Kind = dp) :: xwrk, xwrk1
    !
    !
    Integer(kind = i4) :: ICRS, IDCR, ILOW, NDON
    !
    xwrkt(1) = xdont(1)
    Do icrs = 2, nord
      xwrk = xdont(icrs)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk >= xwrkt(idcr)) Exit
        xwrkt(idcr + 1) = xwrkt(idcr)
      End Do
      xwrkt(idcr + 1) = xwrk
    End Do
    !
    ndon = SIZE (xdont)
    xwrk1 = xwrkt(nord)
    ilow = 2 * nord - ndon
    Do icrs = nord + 1, ndon
      If (xdont(icrs) < xwrk1) Then
        xwrk = xdont(icrs)
        Do idcr = nord - 1, max(1, ilow), - 1
          If (xwrk >= xwrkt(idcr)) Exit
          xwrkt(idcr + 1) = xwrkt(idcr)
        End Do
        xwrkt(idcr + 1) = xwrk
        xwrk1 = xwrkt(nord)
      End If
      ilow = ilow + 1
    End Do
    fndnth = xwrk1
 
    !
  End Function d_fndnth
 
  Function r_fndnth (XDONT, NORD) Result (FNDNTH)
    !  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
    ! ______________________________________________________________________
    !  This subroutine uses insertion sort, limiting insertion
    !  to the first NORD values. It is faster when NORD is very small (2-5),
    !  and it requires only a workarray of size NORD and type of XDONT,
    !  but worst case behavior can happen fairly probably (initially inverse
    !  sorted). In many cases, the refined quicksort method is faster.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Real(kind = sp) :: fndnth
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Real(kind = sp), Dimension (NORD) :: xwrkt
    Real(kind = sp) :: xwrk, xwrk1
    !
    !
    Integer(kind = i4) :: ICRS, IDCR, ILOW, NDON
    !
    xwrkt(1) = xdont(1)
    Do icrs = 2, nord
      xwrk = xdont(icrs)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk >= xwrkt(idcr)) Exit
        xwrkt(idcr + 1) = xwrkt(idcr)
      End Do
      xwrkt(idcr + 1) = xwrk
    End Do
    !
    ndon = SIZE (xdont)
    xwrk1 = xwrkt(nord)
    ilow = 2 * nord - ndon
    Do icrs = nord + 1, ndon
      If (xdont(icrs) < xwrk1) Then
        xwrk = xdont(icrs)
        Do idcr = nord - 1, max(1, ilow), - 1
          If (xwrk >= xwrkt(idcr)) Exit
          xwrkt(idcr + 1) = xwrkt(idcr)
        End Do
        xwrkt(idcr + 1) = xwrk
        xwrk1 = xwrkt(nord)
      End If
      ilow = ilow + 1
    End Do
    fndnth = xwrk1
 
    !
  End Function r_fndnth
 
  Function i_fndnth (XDONT, NORD) Result (FNDNTH)
    !  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
    ! ______________________________________________________________________
    !  This subroutine uses insertion sort, limiting insertion
    !  to the first NORD values. It is faster when NORD is very small (2-5),
    !  and it requires only a workarray of size NORD and type of XDONT,
    !  but worst case behavior can happen fairly probably (initially inverse
    !  sorted). In many cases, the refined quicksort method is faster.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4) :: fndnth
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Integer(kind = i4), Dimension (NORD) :: XWRKT
    Integer(kind = i4) :: XWRK, XWRK1
    !
    !
    Integer(kind = i4) :: ICRS, IDCR, ILOW, NDON
    !
    xwrkt(1) = xdont(1)
    Do icrs = 2, nord
      xwrk = xdont(icrs)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk >= xwrkt(idcr)) Exit
        xwrkt(idcr + 1) = xwrkt(idcr)
      End Do
      xwrkt(idcr + 1) = xwrk
    End Do
    !
    ndon = SIZE (xdont)
    xwrk1 = xwrkt(nord)
    ilow = 2 * nord - ndon
    Do icrs = nord + 1, ndon
      If (xdont(icrs) < xwrk1) Then
        xwrk = xdont(icrs)
        Do idcr = nord - 1, max(1, ilow), - 1
          If (xwrk >= xwrkt(idcr)) Exit
          xwrkt(idcr + 1) = xwrkt(idcr)
        End Do
        xwrkt(idcr + 1) = xwrk
        xwrk1 = xwrkt(nord)
      End If
      ilow = ilow + 1
    End Do
    fndnth = xwrk1
 
    !
  End Function i_fndnth
 
  Subroutine d_indmed (XDONT, INDM)
    !  Returns index of median value of XDONT.
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Intent (Out) :: INDM
    ! __________________________________________________________
    Integer(kind = i4) :: IDON
    !
    Allocate (idont(SIZE(xdont)))
    Do idon = 1, SIZE(xdont)
      idont(idon) = idon
    End Do
    !
    Call d_med (xdont, idont, indm)
    !
    Deallocate (idont)
  End Subroutine d_indmed
 
  Recursive Subroutine d_med (XDATT, IDATT, ires_med)
    !  Finds the index of the median of XDONT using the recursive procedure
    !  described in Knuth, The Art of Computer Programming,
    !  vol. 3, 5.3.3 - This procedure is linear in time, and
    !  does not require to be able to interpolate in the
    !  set as the one used in INDNTH. It also has better worst
    !  case behavior than INDNTH, but is about 30% slower in
    !  average for random uniformly distributed values.
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdatt
    Integer(kind = i4), Dimension (:), Intent (In) :: IDATT
    Integer(kind = i4), Intent (Out) :: ires_med
    ! __________________________________________________________
    !
    real(kind = dp), Parameter :: xhuge = huge(xdatt)
    real(kind = dp) :: xwrk, xwrk1, xmed7, xmax, xmin
    !
    Integer(kind = i4), Dimension (7 * (((Size (IDATT) + 6) / 7 + 6) / 7)) :: ISTRT, IENDT, IMEDT
    Integer(kind = i4), Dimension (7 * ((Size(IDATT) + 6) / 7)) :: IWRKT
    Integer(kind = i4) :: NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
    Integer(kind = i4) :: IDEB, ITMP, IDCR, ICRS, ICRS1, ICRS2, IMAX, IMIN
    Integer(kind = i4) :: IWRK, IWRK1, IMED1, IMED7, NDAT
    !
    ndat = Size (idatt)
    nmed = (ndat + 1) / 2
    iwrkt = idatt
    !
    !  If the number of values is small, then use insertion sort
    !
    If (ndat < 35) Then
      !
      !  Bring minimum to first location to save test in decreasing loop
      !
      idcr = ndat
      If (xdatt(iwrkt(1)) < xdatt(iwrkt(idcr))) Then
        iwrk = iwrkt(1)
      Else
        iwrk = iwrkt(idcr)
        iwrkt(idcr) = iwrkt(1)
      end if
      xwrk = xdatt(iwrk)
      Do itmp = 1, ndat - 2
        idcr = idcr - 1
        iwrk1 = iwrkt(idcr)
        xwrk1 = xdatt(iwrk1)
        If (xwrk1 < xwrk) Then
          iwrkt(idcr) = iwrk
          xwrk = xwrk1
          iwrk = iwrk1
        end if
      End Do
      iwrkt(1) = iwrk
      !
      ! Sort the first half, until we have NMED sorted values
      !
      Do icrs = 3, nmed
        xwrk = xdatt(iwrkt(icrs))
        iwrk = iwrkt(icrs)
        idcr = icrs - 1
        Do
          If (xwrk >= xdatt(iwrkt(idcr))) Exit
          iwrkt(idcr + 1) = iwrkt(idcr)
          idcr = idcr - 1
        End Do
        iwrkt(idcr + 1) = iwrk
      End Do
      !
      !  Insert any value less than the current median in the first half
      !
      xwrk1 = xdatt(iwrkt(nmed))
      Do icrs = nmed + 1, ndat
        xwrk = xdatt(iwrkt(icrs))
        iwrk = iwrkt(icrs)
        If (xwrk < xwrk1) Then
          idcr = nmed - 1
          Do
            If (xwrk >= xdatt(iwrkt(idcr))) Exit
            iwrkt(idcr + 1) = iwrkt(idcr)
            idcr = idcr - 1
          End Do
          iwrkt(idcr + 1) = iwrk
          xwrk1 = xdatt(iwrkt(nmed))
        End If
      End Do
      ires_med = iwrkt(nmed)
      Return
    End If
    !
    !  Make sorted subsets of 7 elements
    !  This is done by a variant of insertion sort where a first
    !  pass is used to bring the smallest element to the first position
    !  decreasing disorder at the same time, so that we may remove
    !  remove the loop test in the insertion loop.
    !
    imax = 1
    imin = 1
    xmax = xdatt(iwrkt(imax))
    xmin = xdatt(iwrkt(imin))
    DO ideb = 1, ndat - 6, 7
      idcr = ideb + 6
      If (xdatt(iwrkt(ideb)) < xdatt(iwrkt(idcr))) Then
        iwrk = iwrkt(ideb)
      Else
        iwrk = iwrkt(idcr)
        iwrkt(idcr) = iwrkt(ideb)
      end if
      xwrk = xdatt(iwrk)
      Do itmp = 1, 5
        idcr = idcr - 1
        iwrk1 = iwrkt(idcr)
        xwrk1 = xdatt(iwrk1)
        If (xwrk1 < xwrk) Then
          iwrkt(idcr) = iwrk
          iwrk = iwrk1
          xwrk = xwrk1
        end if
      End Do
      iwrkt(ideb) = iwrk
      If (xwrk < xmin) Then
        imin = iwrk
        xmin = xwrk
      End If
      Do icrs = ideb + 1, ideb + 5
        iwrk = iwrkt(icrs + 1)
        xwrk = xdatt(iwrk)
        idon = iwrkt(icrs)
        If (xwrk < xdatt(idon)) Then
          iwrkt(icrs + 1) = idon
          idcr = icrs
          iwrk1 = iwrkt(idcr - 1)
          xwrk1 = xdatt(iwrk1)
          Do
            If (xwrk >= xwrk1) Exit
            iwrkt(idcr) = iwrk1
            idcr = idcr - 1
            iwrk1 = iwrkt(idcr - 1)
            xwrk1 = xdatt(iwrk1)
          End Do
          iwrkt(idcr) = iwrk
        end if
      End Do
      If (xwrk > xmax) Then
        imax = iwrk
        xmax = xwrk
      End If
    End Do
    !
    !  Add-up alternatively MAX and MIN values to make the number of data
    !  an exact multiple of 7.
    !
    ideb = 7 * (ndat / 7)
    ntri = ndat
    If (ideb < ndat) Then
      !
      Do icrs = ideb + 1, ndat
        xwrk1 = xdatt(iwrkt(icrs))
        IF (xwrk1 > xmax) Then
          imax = iwrkt(icrs)
          xmax = xwrk1
        End If
        IF (xwrk1 < xmin) Then
          imin = iwrkt(icrs)
          xmin = xwrk1
        End If
      End Do
      iwrk1 = imax
      Do icrs = ndat + 1, ideb + 7
        iwrkt(icrs) = iwrk1
        If (iwrk1 == imax) Then
          iwrk1 = imin
        Else
          nmed = nmed + 1
          iwrk1 = imax
        End If
      End Do
      !
      Do icrs = ideb + 2, ideb + 7
        iwrk = iwrkt(icrs)
        xwrk = xdatt(iwrk)
        Do idcr = icrs - 1, ideb + 1, - 1
          If (xwrk >= xdatt(iwrkt(idcr))) Exit
          iwrkt(idcr + 1) = iwrkt(idcr)
        End Do
        iwrkt(idcr + 1) = iwrk
      End Do
      !
      ntri = ideb + 7
    End If
    !
    !  Make the set of the indices of median values of each sorted subset
    !
    idon1 = 0
    Do idon = 1, ntri, 7
      idon1 = idon1 + 1
      imedt(idon1) = iwrkt(idon + 3)
    End Do
    !
    !  Find XMED7, the median of the medians
    !
    Call d_med (xdatt, imedt(1 : idon1), imed7)
    xmed7 = xdatt(imed7)
    !
    !  Count how many values are not higher than (and how many equal to) XMED7
    !  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
    !  subsets where the median is lower than the median of medians. For similar
    !  reasons, we also have at least 2N/7 values not lower than XMED7. At the
    !  same time, we find in each subset the index of the last value < XMED7,
    !  and that of the first > XMED7. These indices will be used to restrict the
    !  search for the median as the Kth element in the subset (> or <) where
    !  we know it to be.
    !
    idon1 = 1
    nleq = 0
    nequ = 0
    Do idon = 1, ntri, 7
      imed = idon + 3
      If (xdatt(iwrkt(imed)) > xmed7) Then
        imed = imed - 2
        If (xdatt(iwrkt(imed)) > xmed7) Then
          imed = imed - 1
        Else If (xdatt(iwrkt(imed)) < xmed7) Then
          imed = imed + 1
        end if
      Else If (xdatt(iwrkt(imed)) < xmed7) Then
        imed = imed + 2
        If (xdatt(iwrkt(imed)) > xmed7) Then
          imed = imed - 1
        Else If (xdatt(iwrkt(imed)) < xmed7) Then
          imed = imed + 1
        end if
      end if
      If (xdatt(iwrkt(imed)) > xmed7) Then
        nleq = nleq + imed - idon
        iendt(idon1) = imed - 1
        istrt(idon1) = imed
      Else If (xdatt(iwrkt(imed)) < xmed7) Then
        nleq = nleq + imed - idon + 1
        iendt(idon1) = imed
        istrt(idon1) = imed + 1
      Else                    !       If (XDATT (IWRKT (IMED)) == XMED7)
        nleq = nleq + imed - idon + 1
        nequ = nequ + 1
        iendt(idon1) = imed - 1
        Do imed1 = imed - 1, idon, -1
          If (eq(xdatt(iwrkt(imed1)), xmed7)) Then
            nequ = nequ + 1
            iendt(idon1) = imed1 - 1
          Else
            Exit
          End If
        End Do
        istrt(idon1) = imed + 1
        Do imed1 = imed + 1, idon + 6
          If (eq(xdatt(iwrkt(imed1)), xmed7)) Then
            nequ = nequ + 1
            nleq = nleq + 1
            istrt(idon1) = imed1 + 1
          Else
            Exit
          End If
        End Do
      end if
      idon1 = idon1 + 1
    End Do
    !
    !  Carry out a partial insertion sort to find the Kth smallest of the
    !  large values, or the Kth largest of the small values, according to
    !  what is needed.
    !
    !
    If (nleq - nequ + 1 <= nmed) Then
      If (nleq < nmed) Then   !      Not enough low values
        iwrk1 = imax
        xwrk1 = xdatt(iwrk1)
        nord = nmed - nleq
        idon1 = 0
        icrs1 = 1
        icrs2 = 0
        idcr = 0
        Do idon = 1, ntri, 7
          idon1 = idon1 + 1
          If (icrs2 < nord) Then
            Do icrs = istrt(idon1), idon + 6
              If (xdatt(iwrkt(icrs)) < xwrk1) Then
                iwrk = iwrkt(icrs)
                xwrk = xdatt(iwrk)
                Do idcr = icrs1 - 1, 1, - 1
                  If (xwrk >= xdatt(iwrkt(idcr))) Exit
                  iwrkt(idcr + 1) = iwrkt(idcr)
                End Do
                iwrkt(idcr + 1) = iwrk
                iwrk1 = iwrkt(icrs1)
                xwrk1 = xdatt(iwrk1)
              Else
                If (icrs2 < nord) Then
                  iwrkt(icrs1) = iwrkt(icrs)
                  iwrk1 = iwrkt(icrs1)
                  xwrk1 = xdatt(iwrk1)
                end if
              End If
              icrs1 = min(nord, icrs1 + 1)
              icrs2 = min(nord, icrs2 + 1)
            End Do
          Else
            Do icrs = istrt(idon1), idon + 6
              If (xdatt(iwrkt(icrs)) >= xwrk1) Exit
              iwrk = iwrkt(icrs)
              xwrk = xdatt(iwrk)
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk >= xdatt(iwrkt(idcr))) Exit
                iwrkt(idcr + 1) = iwrkt(idcr)
              End Do
              iwrkt(idcr + 1) = iwrk
              iwrk1 = iwrkt(icrs1)
              xwrk1 = xdatt(iwrk1)
            End Do
          End If
        End Do
        ires_med = iwrk1
        Return
      Else
        ires_med = imed7
        Return
      End If
    Else                       !      If (NLEQ > NMED)
      !                                          Not enough high values
      xwrk1 = -xhuge
      nord = nleq - nequ - nmed + 1
      idon1 = 0
      icrs1 = 1
      icrs2 = 0
      Do idon = 1, ntri, 7
        idon1 = idon1 + 1
        If (icrs2 < nord) Then
          !
          Do icrs = idon, iendt(idon1)
            If (xdatt(iwrkt(icrs)) > xwrk1) Then
              iwrk = iwrkt(icrs)
              xwrk = xdatt(iwrk)
              idcr = icrs1 - 1
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk <= xdatt(iwrkt(idcr))) Exit
                iwrkt(idcr + 1) = iwrkt(idcr)
              End Do
              iwrkt(idcr + 1) = iwrk
              iwrk1 = iwrkt(icrs1)
              xwrk1 = xdatt(iwrk1)
            Else
              If (icrs2 < nord) Then
                iwrkt(icrs1) = iwrkt(icrs)
                iwrk1 = iwrkt(icrs1)
                xwrk1 = xdatt(iwrk1)
              End If
            End If
            icrs1 = min(nord, icrs1 + 1)
            icrs2 = min(nord, icrs2 + 1)
          End Do
        Else
          Do icrs = iendt(idon1), idon, -1
            If (xdatt(iwrkt(icrs)) <= xwrk1) Exit
            iwrk = iwrkt(icrs)
            xwrk = xdatt(iwrk)
            idcr = icrs1 - 1
            Do idcr = icrs1 - 1, 1, - 1
              If (xwrk <= xdatt(iwrkt(idcr))) Exit
              iwrkt(idcr + 1) = iwrkt(idcr)
            End Do
            iwrkt(idcr + 1) = iwrk
            iwrk1 = iwrkt(icrs1)
            xwrk1 = xdatt(iwrk1)
          End Do
        end if
      End Do
      !
      ires_med = iwrk1
      Return
    End If
    !
  END Subroutine d_med
  !
  Subroutine r_indmed (XDONT, INDM)
    !  Returns index of median value of XDONT.
    ! __________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Intent (Out) :: INDM
    ! __________________________________________________________
    Integer(kind = i4) :: IDON
    !
    Allocate (idont(SIZE(xdont)))
    Do idon = 1, SIZE(xdont)
      idont(idon) = idon
    End Do
    !
    Call r_med (xdont, idont, indm)
    !
    Deallocate (idont)
  End Subroutine r_indmed
 
  Recursive Subroutine r_med (XDATT, IDATT, ires_med)
    !  Finds the index of the median of XDONT using the recursive procedure
    !  described in Knuth, The Art of Computer Programming,
    !  vol. 3, 5.3.3 - This procedure is linear in time, and
    !  does not require to be able to interpolate in the
    !  set as the one used in INDNTH. It also has better worst
    !  case behavior than INDNTH, but is about 30% slower in
    !  average for random uniformly distributed values.
    ! __________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdatt
    Integer(kind = i4), Dimension (:), Intent (In) :: IDATT
    Integer(kind = i4), Intent (Out) :: ires_med
    ! __________________________________________________________
    !
    Real(kind = sp), Parameter :: xhuge = huge(xdatt)
    Real(kind = sp) :: xwrk, xwrk1, xmed7, xmax, xmin
    !
    Integer(kind = i4), Dimension (7 * (((Size (IDATT) + 6) / 7 + 6) / 7)) :: ISTRT, IENDT, IMEDT
    Integer(kind = i4), Dimension (7 * ((Size(IDATT) + 6) / 7)) :: IWRKT
    Integer(kind = i4) :: NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
    Integer(kind = i4) :: IDEB, ITMP, IDCR, ICRS, ICRS1, ICRS2, IMAX, IMIN
    Integer(kind = i4) :: IWRK, IWRK1, IMED1, IMED7, NDAT
    !
    ndat = Size (idatt)
    nmed = (ndat + 1) / 2
    iwrkt = idatt
    !
    !  If the number of values is small, then use insertion sort
    !
    If (ndat < 35) Then
      !
      !  Bring minimum to first location to save test in decreasing loop
      !
      idcr = ndat
      If (xdatt(iwrkt(1)) < xdatt(iwrkt(idcr))) Then
        iwrk = iwrkt(1)
      Else
        iwrk = iwrkt(idcr)
        iwrkt(idcr) = iwrkt(1)
      end if
      xwrk = xdatt(iwrk)
      Do itmp = 1, ndat - 2
        idcr = idcr - 1
        iwrk1 = iwrkt(idcr)
        xwrk1 = xdatt(iwrk1)
        If (xwrk1 < xwrk) Then
          iwrkt(idcr) = iwrk
          xwrk = xwrk1
          iwrk = iwrk1
        end if
      End Do
      iwrkt(1) = iwrk
      !
      ! Sort the first half, until we have NMED sorted values
      !
      Do icrs = 3, nmed
        xwrk = xdatt(iwrkt(icrs))
        iwrk = iwrkt(icrs)
        idcr = icrs - 1
        Do
          If (xwrk >= xdatt(iwrkt(idcr))) Exit
          iwrkt(idcr + 1) = iwrkt(idcr)
          idcr = idcr - 1
        End Do
        iwrkt(idcr + 1) = iwrk
      End Do
      !
      !  Insert any value less than the current median in the first half
      !
      xwrk1 = xdatt(iwrkt(nmed))
      Do icrs = nmed + 1, ndat
        xwrk = xdatt(iwrkt(icrs))
        iwrk = iwrkt(icrs)
        If (xwrk < xwrk1) Then
          idcr = nmed - 1
          Do
            If (xwrk >= xdatt(iwrkt(idcr))) Exit
            iwrkt(idcr + 1) = iwrkt(idcr)
            idcr = idcr - 1
          End Do
          iwrkt(idcr + 1) = iwrk
          xwrk1 = xdatt(iwrkt(nmed))
        End If
      End Do
      ires_med = iwrkt(nmed)
      Return
    End If
    !
    !  Make sorted subsets of 7 elements
    !  This is done by a variant of insertion sort where a first
    !  pass is used to bring the smallest element to the first position
    !  decreasing disorder at the same time, so that we may remove
    !  remove the loop test in the insertion loop.
    !
    imax = 1
    imin = 1
    xmax = xdatt(iwrkt(imax))
    xmin = xdatt(iwrkt(imin))
    DO ideb = 1, ndat - 6, 7
      idcr = ideb + 6
      If (xdatt(iwrkt(ideb)) < xdatt(iwrkt(idcr))) Then
        iwrk = iwrkt(ideb)
      Else
        iwrk = iwrkt(idcr)
        iwrkt(idcr) = iwrkt(ideb)
      end if
      xwrk = xdatt(iwrk)
      Do itmp = 1, 5
        idcr = idcr - 1
        iwrk1 = iwrkt(idcr)
        xwrk1 = xdatt(iwrk1)
        If (xwrk1 < xwrk) Then
          iwrkt(idcr) = iwrk
          iwrk = iwrk1
          xwrk = xwrk1
        end if
      End Do
      iwrkt(ideb) = iwrk
      If (xwrk < xmin) Then
        imin = iwrk
        xmin = xwrk
      End If
      Do icrs = ideb + 1, ideb + 5
        iwrk = iwrkt(icrs + 1)
        xwrk = xdatt(iwrk)
        idon = iwrkt(icrs)
        If (xwrk < xdatt(idon)) Then
          iwrkt(icrs + 1) = idon
          idcr = icrs
          iwrk1 = iwrkt(idcr - 1)
          xwrk1 = xdatt(iwrk1)
          Do
            If (xwrk >= xwrk1) Exit
            iwrkt(idcr) = iwrk1
            idcr = idcr - 1
            iwrk1 = iwrkt(idcr - 1)
            xwrk1 = xdatt(iwrk1)
          End Do
          iwrkt(idcr) = iwrk
        end if
      End Do
      If (xwrk > xmax) Then
        imax = iwrk
        xmax = xwrk
      End If
    End Do
    !
    !  Add-up alternatively MAX and MIN values to make the number of data
    !  an exact multiple of 7.
    !
    ideb = 7 * (ndat / 7)
    ntri = ndat
    If (ideb < ndat) Then
      !
      Do icrs = ideb + 1, ndat
        xwrk1 = xdatt(iwrkt(icrs))
        IF (xwrk1 > xmax) Then
          imax = iwrkt(icrs)
          xmax = xwrk1
        End If
        IF (xwrk1 < xmin) Then
          imin = iwrkt(icrs)
          xmin = xwrk1
        End If
      End Do
      iwrk1 = imax
      Do icrs = ndat + 1, ideb + 7
        iwrkt(icrs) = iwrk1
        If (iwrk1 == imax) Then
          iwrk1 = imin
        Else
          nmed = nmed + 1
          iwrk1 = imax
        End If
      End Do
      !
      Do icrs = ideb + 2, ideb + 7
        iwrk = iwrkt(icrs)
        xwrk = xdatt(iwrk)
        Do idcr = icrs - 1, ideb + 1, - 1
          If (xwrk >= xdatt(iwrkt(idcr))) Exit
          iwrkt(idcr + 1) = iwrkt(idcr)
        End Do
        iwrkt(idcr + 1) = iwrk
      End Do
      !
      ntri = ideb + 7
    End If
    !
    !  Make the set of the indices of median values of each sorted subset
    !
    idon1 = 0
    Do idon = 1, ntri, 7
      idon1 = idon1 + 1
      imedt(idon1) = iwrkt(idon + 3)
    End Do
    !
    !  Find XMED7, the median of the medians
    !
    Call r_med (xdatt, imedt(1 : idon1), imed7)
    xmed7 = xdatt(imed7)
    !
    !  Count how many values are not higher than (and how many equal to) XMED7
    !  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
    !  subsets where the median is lower than the median of medians. For similar
    !  reasons, we also have at least 2N/7 values not lower than XMED7. At the
    !  same time, we find in each subset the index of the last value < XMED7,
    !  and that of the first > XMED7. These indices will be used to restrict the
    !  search for the median as the Kth element in the subset (> or <) where
    !  we know it to be.
    !
    idon1 = 1
    nleq = 0
    nequ = 0
    Do idon = 1, ntri, 7
      imed = idon + 3
      If (xdatt(iwrkt(imed)) > xmed7) Then
        imed = imed - 2
        If (xdatt(iwrkt(imed)) > xmed7) Then
          imed = imed - 1
        Else If (xdatt(iwrkt(imed)) < xmed7) Then
          imed = imed + 1
        end if
      Else If (xdatt(iwrkt(imed)) < xmed7) Then
        imed = imed + 2
        If (xdatt(iwrkt(imed)) > xmed7) Then
          imed = imed - 1
        Else If (xdatt(iwrkt(imed)) < xmed7) Then
          imed = imed + 1
        end if
      end if
      If (xdatt(iwrkt(imed)) > xmed7) Then
        nleq = nleq + imed - idon
        iendt(idon1) = imed - 1
        istrt(idon1) = imed
      Else If (xdatt(iwrkt(imed)) < xmed7) Then
        nleq = nleq + imed - idon + 1
        iendt(idon1) = imed
        istrt(idon1) = imed + 1
      Else                    !       If (XDATT (IWRKT (IMED)) == XMED7)
        nleq = nleq + imed - idon + 1
        nequ = nequ + 1
        iendt(idon1) = imed - 1
        Do imed1 = imed - 1, idon, -1
          If (eq(xdatt(iwrkt(imed1)), xmed7)) Then
            nequ = nequ + 1
            iendt(idon1) = imed1 - 1
          Else
            Exit
          End If
        End Do
        istrt(idon1) = imed + 1
        Do imed1 = imed + 1, idon + 6
          If (eq(xdatt(iwrkt(imed1)), xmed7)) Then
            nequ = nequ + 1
            nleq = nleq + 1
            istrt(idon1) = imed1 + 1
          Else
            Exit
          End If
        End Do
      end if
      idon1 = idon1 + 1
    End Do
    !
    !  Carry out a partial insertion sort to find the Kth smallest of the
    !  large values, or the Kth largest of the small values, according to
    !  what is needed.
    !
    !
    If (nleq - nequ + 1 <= nmed) Then
      If (nleq < nmed) Then   !      Not enough low values
        iwrk1 = imax
        xwrk1 = xdatt(iwrk1)
        nord = nmed - nleq
        idon1 = 0
        icrs1 = 1
        icrs2 = 0
        idcr = 0
        Do idon = 1, ntri, 7
          idon1 = idon1 + 1
          If (icrs2 < nord) Then
            Do icrs = istrt(idon1), idon + 6
              If (xdatt(iwrkt(icrs)) < xwrk1) Then
                iwrk = iwrkt(icrs)
                xwrk = xdatt(iwrk)
                Do idcr = icrs1 - 1, 1, - 1
                  If (xwrk >= xdatt(iwrkt(idcr))) Exit
                  iwrkt(idcr + 1) = iwrkt(idcr)
                End Do
                iwrkt(idcr + 1) = iwrk
                iwrk1 = iwrkt(icrs1)
                xwrk1 = xdatt(iwrk1)
              Else
                If (icrs2 < nord) Then
                  iwrkt(icrs1) = iwrkt(icrs)
                  iwrk1 = iwrkt(icrs1)
                  xwrk1 = xdatt(iwrk1)
                end if
              End If
              icrs1 = min(nord, icrs1 + 1)
              icrs2 = min(nord, icrs2 + 1)
            End Do
          Else
            Do icrs = istrt(idon1), idon + 6
              If (xdatt(iwrkt(icrs)) >= xwrk1) Exit
              iwrk = iwrkt(icrs)
              xwrk = xdatt(iwrk)
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk >= xdatt(iwrkt(idcr))) Exit
                iwrkt(idcr + 1) = iwrkt(idcr)
              End Do
              iwrkt(idcr + 1) = iwrk
              iwrk1 = iwrkt(icrs1)
              xwrk1 = xdatt(iwrk1)
            End Do
          End If
        End Do
        ires_med = iwrk1
        Return
      Else
        ires_med = imed7
        Return
      End If
    Else                       !      If (NLEQ > NMED)
      !                                          Not enough high values
      xwrk1 = -xhuge
      nord = nleq - nequ - nmed + 1
      idon1 = 0
      icrs1 = 1
      icrs2 = 0
      Do idon = 1, ntri, 7
        idon1 = idon1 + 1
        If (icrs2 < nord) Then
          !
          Do icrs = idon, iendt(idon1)
            If (xdatt(iwrkt(icrs)) > xwrk1) Then
              iwrk = iwrkt(icrs)
              xwrk = xdatt(iwrk)
              idcr = icrs1 - 1
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk <= xdatt(iwrkt(idcr))) Exit
                iwrkt(idcr + 1) = iwrkt(idcr)
              End Do
              iwrkt(idcr + 1) = iwrk
              iwrk1 = iwrkt(icrs1)
              xwrk1 = xdatt(iwrk1)
            Else
              If (icrs2 < nord) Then
                iwrkt(icrs1) = iwrkt(icrs)
                iwrk1 = iwrkt(icrs1)
                xwrk1 = xdatt(iwrk1)
              End If
            End If
            icrs1 = min(nord, icrs1 + 1)
            icrs2 = min(nord, icrs2 + 1)
          End Do
        Else
          Do icrs = iendt(idon1), idon, -1
            If (xdatt(iwrkt(icrs)) <= xwrk1) Exit
            iwrk = iwrkt(icrs)
            xwrk = xdatt(iwrk)
            idcr = icrs1 - 1
            Do idcr = icrs1 - 1, 1, - 1
              If (xwrk <= xdatt(iwrkt(idcr))) Exit
              iwrkt(idcr + 1) = iwrkt(idcr)
            End Do
            iwrkt(idcr + 1) = iwrk
            iwrk1 = iwrkt(icrs1)
            xwrk1 = xdatt(iwrk1)
          End Do
        end if
      End Do
      !
      ires_med = iwrk1
      Return
    End If
    !
  END Subroutine r_med
 
  Subroutine i_indmed (XDONT, INDM)
    !  Returns index of median value of XDONT.
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4), Intent (Out) :: INDM
    ! __________________________________________________________
    Integer(kind = i4) :: IDON
    !
    Allocate (idont(SIZE(xdont)))
    Do idon = 1, SIZE(xdont)
      idont(idon) = idon
    End Do
    !
    Call i_med(xdont, idont, indm)
    !
    Deallocate (idont)
  End Subroutine i_indmed
 
  Recursive Subroutine i_med (XDATT, IDATT, ires_med)
    !  Finds the index of the median of XDONT using the recursive procedure
    !  described in Knuth, The Art of Computer Programming,
    !  vol. 3, 5.3.3 - This procedure is linear in time, and
    !  does not require to be able to interpolate in the
    !  set as the one used in INDNTH. It also has better worst
    !  case behavior than INDNTH, but is about 30% slower in
    !  average for random uniformly distributed values.
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDATT
    Integer(kind = i4), Dimension (:), Intent (In) :: IDATT
    Integer(kind = i4), Intent (Out) :: ires_med
    ! __________________________________________________________
    !
    Integer(kind = i4), Parameter :: XHUGE = huge (xdatt)
    Integer(kind = i4) :: XWRK, XWRK1, XMED7, XMAX, XMIN
    !
    Integer(kind = i4), Dimension (7 * (((Size (IDATT) + 6) / 7 + 6) / 7)) :: ISTRT, IENDT, IMEDT
    Integer(kind = i4), Dimension (7 * ((Size(IDATT) + 6) / 7)) :: IWRKT
    Integer(kind = i4) :: NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
    Integer(kind = i4) :: IDEB, ITMP, IDCR, ICRS, ICRS1, ICRS2, IMAX, IMIN
    Integer(kind = i4) :: IWRK, IWRK1, IMED1, IMED7, NDAT
    !
    ndat = Size (idatt)
    nmed = (ndat + 1) / 2
    iwrkt = idatt
    !
    !  If the number of values is small, then use insertion sort
    !
    If (ndat < 35) Then
      !
      !  Bring minimum to first location to save test in decreasing loop
      !
      idcr = ndat
      If (xdatt(iwrkt(1)) < xdatt(iwrkt(idcr))) Then
        iwrk = iwrkt(1)
      Else
        iwrk = iwrkt(idcr)
        iwrkt(idcr) = iwrkt(1)
      end if
      xwrk = xdatt(iwrk)
      Do itmp = 1, ndat - 2
        idcr = idcr - 1
        iwrk1 = iwrkt(idcr)
        xwrk1 = xdatt(iwrk1)
        If (xwrk1 < xwrk) Then
          iwrkt(idcr) = iwrk
          xwrk = xwrk1
          iwrk = iwrk1
        end if
      End Do
      iwrkt(1) = iwrk
      !
      ! Sort the first half, until we have NMED sorted values
      !
      Do icrs = 3, nmed
        xwrk = xdatt(iwrkt(icrs))
        iwrk = iwrkt(icrs)
        idcr = icrs - 1
        Do
          If (xwrk >= xdatt(iwrkt(idcr))) Exit
          iwrkt(idcr + 1) = iwrkt(idcr)
          idcr = idcr - 1
        End Do
        iwrkt(idcr + 1) = iwrk
      End Do
      !
      !  Insert any value less than the current median in the first half
      !
      xwrk1 = xdatt(iwrkt(nmed))
      Do icrs = nmed + 1, ndat
        xwrk = xdatt(iwrkt(icrs))
        iwrk = iwrkt(icrs)
        If (xwrk < xwrk1) Then
          idcr = nmed - 1
          Do
            If (xwrk >= xdatt(iwrkt(idcr))) Exit
            iwrkt(idcr + 1) = iwrkt(idcr)
            idcr = idcr - 1
          End Do
          iwrkt(idcr + 1) = iwrk
          xwrk1 = xdatt(iwrkt(nmed))
        End If
      End Do
      ires_med = iwrkt(nmed)
      Return
    End If
    !
    !  Make sorted subsets of 7 elements
    !  This is done by a variant of insertion sort where a first
    !  pass is used to bring the smallest element to the first position
    !  decreasing disorder at the same time, so that we may remove
    !  remove the loop test in the insertion loop.
    !
    imax = 1
    imin = 1
    xmax = xdatt(iwrkt(imax))
    xmin = xdatt(iwrkt(imin))
    DO ideb = 1, ndat - 6, 7
      idcr = ideb + 6
      If (xdatt(iwrkt(ideb)) < xdatt(iwrkt(idcr))) Then
        iwrk = iwrkt(ideb)
      Else
        iwrk = iwrkt(idcr)
        iwrkt(idcr) = iwrkt(ideb)
      end if
      xwrk = xdatt(iwrk)
      Do itmp = 1, 5
        idcr = idcr - 1
        iwrk1 = iwrkt(idcr)
        xwrk1 = xdatt(iwrk1)
        If (xwrk1 < xwrk) Then
          iwrkt(idcr) = iwrk
          iwrk = iwrk1
          xwrk = xwrk1
        end if
      End Do
      iwrkt(ideb) = iwrk
      If (xwrk < xmin) Then
        imin = iwrk
        xmin = xwrk
      End If
      Do icrs = ideb + 1, ideb + 5
        iwrk = iwrkt(icrs + 1)
        xwrk = xdatt(iwrk)
        idon = iwrkt(icrs)
        If (xwrk < xdatt(idon)) Then
          iwrkt(icrs + 1) = idon
          idcr = icrs
          iwrk1 = iwrkt(idcr - 1)
          xwrk1 = xdatt(iwrk1)
          Do
            If (xwrk >= xwrk1) Exit
            iwrkt(idcr) = iwrk1
            idcr = idcr - 1
            iwrk1 = iwrkt(idcr - 1)
            xwrk1 = xdatt(iwrk1)
          End Do
          iwrkt(idcr) = iwrk
        end if
      End Do
      If (xwrk > xmax) Then
        imax = iwrk
        xmax = xwrk
      End If
    End Do
    !
    !  Add-up alternatively MAX and MIN values to make the number of data
    !  an exact multiple of 7.
    !
    ideb = 7 * (ndat / 7)
    ntri = ndat
    If (ideb < ndat) Then
      !
      Do icrs = ideb + 1, ndat
        xwrk1 = xdatt(iwrkt(icrs))
        IF (xwrk1 > xmax) Then
          imax = iwrkt(icrs)
          xmax = xwrk1
        End If
        IF (xwrk1 < xmin) Then
          imin = iwrkt(icrs)
          xmin = xwrk1
        End If
      End Do
      iwrk1 = imax
      Do icrs = ndat + 1, ideb + 7
        iwrkt(icrs) = iwrk1
        If (iwrk1 == imax) Then
          iwrk1 = imin
        Else
          nmed = nmed + 1
          iwrk1 = imax
        End If
      End Do
      !
      Do icrs = ideb + 2, ideb + 7
        iwrk = iwrkt(icrs)
        xwrk = xdatt(iwrk)
        Do idcr = icrs - 1, ideb + 1, - 1
          If (xwrk >= xdatt(iwrkt(idcr))) Exit
          iwrkt(idcr + 1) = iwrkt(idcr)
        End Do
        iwrkt(idcr + 1) = iwrk
      End Do
      !
      ntri = ideb + 7
    End If
    !
    !  Make the set of the indices of median values of each sorted subset
    !
    idon1 = 0
    Do idon = 1, ntri, 7
      idon1 = idon1 + 1
      imedt(idon1) = iwrkt(idon + 3)
    End Do
    !
    !  Find XMED7, the median of the medians
    !
    Call i_med (xdatt, imedt(1 : idon1), imed7)
    xmed7 = xdatt(imed7)
    !
    !  Count how many values are not higher than (and how many equal to) XMED7
    !  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
    !  subsets where the median is lower than the median of medians. For similar
    !  reasons, we also have at least 2N/7 values not lower than XMED7. At the
    !  same time, we find in each subset the index of the last value < XMED7,
    !  and that of the first > XMED7. These indices will be used to restrict the
    !  search for the median as the Kth element in the subset (> or <) where
    !  we know it to be.
    !
    idon1 = 1
    nleq = 0
    nequ = 0
    Do idon = 1, ntri, 7
      imed = idon + 3
      If (xdatt(iwrkt(imed)) > xmed7) Then
        imed = imed - 2
        If (xdatt(iwrkt(imed)) > xmed7) Then
          imed = imed - 1
        Else If (xdatt(iwrkt(imed)) < xmed7) Then
          imed = imed + 1
        end if
      Else If (xdatt(iwrkt(imed)) < xmed7) Then
        imed = imed + 2
        If (xdatt(iwrkt(imed)) > xmed7) Then
          imed = imed - 1
        Else If (xdatt(iwrkt(imed)) < xmed7) Then
          imed = imed + 1
        end if
      end if
      If (xdatt(iwrkt(imed)) > xmed7) Then
        nleq = nleq + imed - idon
        iendt(idon1) = imed - 1
        istrt(idon1) = imed
      Else If (xdatt(iwrkt(imed)) < xmed7) Then
        nleq = nleq + imed - idon + 1
        iendt(idon1) = imed
        istrt(idon1) = imed + 1
      Else                    !       If (XDATT (IWRKT (IMED)) == XMED7)
        nleq = nleq + imed - idon + 1
        nequ = nequ + 1
        iendt(idon1) = imed - 1
        Do imed1 = imed - 1, idon, -1
          If (xdatt(iwrkt(imed1)) == xmed7) Then
            nequ = nequ + 1
            iendt(idon1) = imed1 - 1
          Else
            Exit
          End If
        End Do
        istrt(idon1) = imed + 1
        Do imed1 = imed + 1, idon + 6
          If (xdatt(iwrkt(imed1)) == xmed7) Then
            nequ = nequ + 1
            nleq = nleq + 1
            istrt(idon1) = imed1 + 1
          Else
            Exit
          End If
        End Do
      end if
      idon1 = idon1 + 1
    End Do
    !
    !  Carry out a partial insertion sort to find the Kth smallest of the
    !  large values, or the Kth largest of the small values, according to
    !  what is needed.
    !
    !
    If (nleq - nequ + 1 <= nmed) Then
      If (nleq < nmed) Then   !      Not enough low values
        iwrk1 = imax
        xwrk1 = xdatt(iwrk1)
        nord = nmed - nleq
        idon1 = 0
        icrs1 = 1
        icrs2 = 0
        idcr = 0
        Do idon = 1, ntri, 7
          idon1 = idon1 + 1
          If (icrs2 < nord) Then
            Do icrs = istrt(idon1), idon + 6
              If (xdatt(iwrkt(icrs)) < xwrk1) Then
                iwrk = iwrkt(icrs)
                xwrk = xdatt(iwrk)
                Do idcr = icrs1 - 1, 1, - 1
                  If (xwrk >= xdatt(iwrkt(idcr))) Exit
                  iwrkt(idcr + 1) = iwrkt(idcr)
                End Do
                iwrkt(idcr + 1) = iwrk
                iwrk1 = iwrkt(icrs1)
                xwrk1 = xdatt(iwrk1)
              Else
                If (icrs2 < nord) Then
                  iwrkt(icrs1) = iwrkt(icrs)
                  iwrk1 = iwrkt(icrs1)
                  xwrk1 = xdatt(iwrk1)
                end if
              End If
              icrs1 = min(nord, icrs1 + 1)
              icrs2 = min(nord, icrs2 + 1)
            End Do
          Else
            Do icrs = istrt(idon1), idon + 6
              If (xdatt(iwrkt(icrs)) >= xwrk1) Exit
              iwrk = iwrkt(icrs)
              xwrk = xdatt(iwrk)
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk >= xdatt(iwrkt(idcr))) Exit
                iwrkt(idcr + 1) = iwrkt(idcr)
              End Do
              iwrkt(idcr + 1) = iwrk
              iwrk1 = iwrkt(icrs1)
              xwrk1 = xdatt(iwrk1)
            End Do
          End If
        End Do
        ires_med = iwrk1
        Return
      Else
        ires_med = imed7
        Return
      End If
    Else                       !      If (NLEQ > NMED)
      !                                          Not enough high values
      xwrk1 = -xhuge
      nord = nleq - nequ - nmed + 1
      idon1 = 0
      icrs1 = 1
      icrs2 = 0
      Do idon = 1, ntri, 7
        idon1 = idon1 + 1
        If (icrs2 < nord) Then
          !
          Do icrs = idon, iendt(idon1)
            If (xdatt(iwrkt(icrs)) > xwrk1) Then
              iwrk = iwrkt(icrs)
              xwrk = xdatt(iwrk)
              idcr = icrs1 - 1
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk <= xdatt(iwrkt(idcr))) Exit
                iwrkt(idcr + 1) = iwrkt(idcr)
              End Do
              iwrkt(idcr + 1) = iwrk
              iwrk1 = iwrkt(icrs1)
              xwrk1 = xdatt(iwrk1)
            Else
              If (icrs2 < nord) Then
                iwrkt(icrs1) = iwrkt(icrs)
                iwrk1 = iwrkt(icrs1)
                xwrk1 = xdatt(iwrk1)
              End If
            End If
            icrs1 = min(nord, icrs1 + 1)
            icrs2 = min(nord, icrs2 + 1)
          End Do
        Else
          Do icrs = iendt(idon1), idon, -1
            If (xdatt(iwrkt(icrs)) <= xwrk1) Exit
            iwrk = iwrkt(icrs)
            xwrk = xdatt(iwrk)
            idcr = icrs1 - 1
            Do idcr = icrs1 - 1, 1, - 1
              If (xwrk <= xdatt(iwrkt(idcr))) Exit
              iwrkt(idcr + 1) = iwrkt(idcr)
            End Do
            iwrkt(idcr + 1) = iwrk
            iwrk1 = iwrkt(icrs1)
            xwrk1 = xdatt(iwrk1)
          End Do
        end if
      End Do
      !
      ires_med = iwrk1
      Return
    End If
    !
  END Subroutine i_med
 
  Function d_indnth (XDONT, NORD) Result (INDNTH)
    !  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then finds the maximum of this set.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4) :: INDNTH
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    real(kind = dp) :: xpiv, xwrk, xwrk1, xmin, xmax
    !
    Integer(kind = i4), Dimension (NORD) :: IRNGT
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
    !
    ndon = SIZE (xdont)
    inth = nord
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (inth == 1) indnth = 1
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      ilowt(1) = 2
      ihigt(1) = 1
    Else
      ilowt(1) = 1
      ihigt(1) = 2
    End If
    !
    If (ndon < 3) Then
      If (inth == 1) indnth = ilowt(1)
      If (inth == 2) indnth = ihigt(1)
      Return
    End If
    !
    If (xdont(3) < xdont(ihigt(1))) Then
      ihigt(2) = ihigt(1)
      If (xdont(3) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = 3
      Else
        ihigt(1) = 3
      End If
    Else
      ihigt(2) = 3
    End If
    !
    If (ndon < 4) Then
      If (inth == 1) indnth = ilowt(1)
      If (inth == 2) indnth = ihigt(1)
      If (inth == 3) indnth = ihigt(2)
      Return
    End If
    !
    If (xdont(ndon) < xdont(ihigt(1))) Then
      ihigt(3) = ihigt(2)
      ihigt(2) = ihigt(1)
      If (xdont(ndon) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = ndon
      Else
        ihigt(1) = ndon
      End If
    Else
      ihigt(3) = ndon
    End If
    !
    If (ndon < 5) Then
      If (inth == 1) indnth = ilowt(1)
      If (inth == 2) indnth = ihigt(1)
      If (inth == 3) indnth = ihigt(2)
      If (inth == 4) indnth = ihigt(3)
      Return
    End If
    !
 
    jlow = 1
    jhig = 3
    xpiv = xdont(ilowt(1)) + real(2 * inth, dp) / real(ndon + inth, dp) * &
            (xdont(ihigt(3)) - xdont(ilowt(1)))
    If (xpiv >= xdont(ihigt(1))) Then
      xpiv = xdont(ilowt(1)) + real(2 * inth, dp) / real(ndon + inth, dp) * &
              (xdont(ihigt(2)) - xdont(ilowt(1)))
      If (xpiv >= xdont(ihigt(1))) &
              xpiv = xdont(ilowt(1)) + real(2 * inth, dp) / real(ndon + inth, dp) * &
                      (xdont(ihigt(1)) - xdont(ilowt(1)))
    End If
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the IHIGT array as soon as we have more
    !  than enough values in ILOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= inth) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            ilowt(jlow) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= inth) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            ilowt(jlow) = icrs
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to INTH
        !
        If (inth > jlow) Then
          xmin = xdont(ihigt(1))
          ihig = 1
          Do icrs = 2, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              xmin = xdont(ihigt(icrs))
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          ilowt(jlow) = ihigt(ihig)
          ihigt(ihig) = ihigt(jhig)
          jhig = jhig - 1
        Else
 
          ilow = ilowt(1)
          xmax = xdont(ilow)
          Do icrs = 2, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              iwrk = ilowt(icrs)
              xmax = xdont(iwrk)
              ilowt(icrs) = ilow
              ilow = iwrk
            End If
          End Do
          jlow = jlow - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to INTH.
      !
      Select Case (inth - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        inth = inth - jlow
        jlow = 0
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (unit=*,fmt=*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xdont(ihigt(1)) <= xdont(ihigt(2))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
          Else
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(3)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(3) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, inth
            jhig = jhig + 1
            ilowt(icrs) = ihigt(jhig)
          End Do
          jlow = inth
          Exit
          !
        Case (4 :)
          !
          !
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(ifin)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(ifin) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          !
          iwrk1 = ihigt(1)
          jlow = jlow + 1
          ilowt(jlow) = iwrk1
          xpiv = xdont(iwrk1) + 0.5 * (xdont(ihigt(ifin)) - xdont(iwrk1))
          !
          !  One takes values <= pivot to ILOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (jlow >= inth) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xdont(ihigt(1))
        ihig = 1
        Do icrs = 2, jhig
          If (xdont(ihigt(icrs)) < xmin) Then
            xmin = xdont(ihigt(icrs))
            ihig = icrs
          End If
        End Do
        !
        indnth = ihigt(ihig)
        Return
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        irngt(1) = ilowt(1)
        ilow = 1 + inth - jlow
        Do icrs = 2, inth
          iwrk = ilowt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, max(1, ilow), - 1
            If (xwrk < xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
          ilow = ilow + 1
        End Do
        !
        xwrk1 = xdont(irngt(inth))
        ilow = 2 * inth - jlow
        Do icrs = inth + 1, jlow
          If (xdont(ilowt(icrs)) < xwrk1) Then
            xwrk = xdont(ilowt(icrs))
            Do idcr = inth - 1, max(1, ilow), - 1
              If (xwrk >= xdont(irngt(idcr))) Exit
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ilowt(icrs)
            xwrk1 = xdont(irngt(inth))
          End If
          ilow = ilow + 1
        End Do
        !
        indnth = irngt(inth)
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
 
        imil = (jlow + 1) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ilowt(imil)) < xdont(ilowt(1))) Then
          iwrk = ilowt(1)
          ilowt(1) = ilowt(imil)
          ilowt(imil) = iwrk
        End If
        If (xdont(ilowt(imil)) > xdont(ilowt(ifin))) Then
          iwrk = ilowt(ifin)
          ilowt(ifin) = ilowt(imil)
          ilowt(imil) = iwrk
          If (xdont(ilowt(imil)) < xdont(ilowt(1))) Then
            iwrk = ilowt(1)
            ilowt(1) = ilowt(imil)
            ilowt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xdont(ilowt(1)) + real(inth, dp) / real(jlow + inth, dp) * &
                (xdont(ilowt(ifin)) - xdont(ilowt(1)))
 
        !
        !  One takes values > XPIV to IHIGT
        !
        jhig = 0
        jlow = 0
        !
        If (xdont(ilowt(ifin)) > xpiv) Then
          icrs = 0
          Do
            icrs = icrs + 1
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ilowt(icrs)) <= xpiv) Then
                jlow = jlow + 1
                ilowt(jlow) = ilowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = 1, ifin
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to find maximum of the 1:INTH set
    !
 
    iwrk1 = ilowt(1)
    xwrk1 = xdont(iwrk1)
    Do icrs = 1 + 1, inth
      iwrk = ilowt(icrs)
      xwrk = xdont(iwrk)
      If (xwrk > xwrk1) Then
        xwrk1 = xwrk
        iwrk1 = iwrk
      End If
    End Do
    indnth = iwrk1
    Return
    !
    !
  End Function d_indnth
 
  Function r_indnth (XDONT, NORD) Result (INDNTH)
    !  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then finds the maximum of this set.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4) :: INDNTH
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Real(kind = sp) :: xpiv, xwrk, xwrk1, xmin, xmax
    !
    Integer(kind = i4), Dimension (NORD) :: IRNGT
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
    !
    ndon = SIZE (xdont)
    inth = nord
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (inth == 1) indnth = 1
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      ilowt(1) = 2
      ihigt(1) = 1
    Else
      ilowt(1) = 1
      ihigt(1) = 2
    End If
    !
    If (ndon < 3) Then
      If (inth == 1) indnth = ilowt(1)
      If (inth == 2) indnth = ihigt(1)
      Return
    End If
    !
    If (xdont(3) < xdont(ihigt(1))) Then
      ihigt(2) = ihigt(1)
      If (xdont(3) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = 3
      Else
        ihigt(1) = 3
      End If
    Else
      ihigt(2) = 3
    End If
    !
    If (ndon < 4) Then
      If (inth == 1) indnth = ilowt(1)
      If (inth == 2) indnth = ihigt(1)
      If (inth == 3) indnth = ihigt(2)
      Return
    End If
    !
    If (xdont(ndon) < xdont(ihigt(1))) Then
      ihigt(3) = ihigt(2)
      ihigt(2) = ihigt(1)
      If (xdont(ndon) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = ndon
      Else
        ihigt(1) = ndon
      End If
    Else
      ihigt(3) = ndon
    End If
    !
    If (ndon < 5) Then
      If (inth == 1) indnth = ilowt(1)
      If (inth == 2) indnth = ihigt(1)
      If (inth == 3) indnth = ihigt(2)
      If (inth == 4) indnth = ihigt(3)
      Return
    End If
    !
 
    jlow = 1
    jhig = 3
    xpiv = xdont(ilowt(1)) + real(2 * inth, sp) / real(ndon + inth, sp) * &
            (xdont(ihigt(3)) - xdont(ilowt(1)))
    If (xpiv >= xdont(ihigt(1))) Then
      xpiv = xdont(ilowt(1)) + real(2 * inth, sp) / real(ndon + inth, sp) * &
              (xdont(ihigt(2)) - xdont(ilowt(1)))
      If (xpiv >= xdont(ihigt(1))) &
              xpiv = xdont(ilowt(1)) + real(2 * inth, sp) / real(ndon + inth, sp) * &
                      (xdont(ihigt(1)) - xdont(ilowt(1)))
    End If
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the IHIGT array as soon as we have more
    !  than enough values in ILOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= inth) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            ilowt(jlow) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= inth) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            ilowt(jlow) = icrs
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to INTH
        !
        If (inth > jlow) Then
          xmin = xdont(ihigt(1))
          ihig = 1
          Do icrs = 2, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              xmin = xdont(ihigt(icrs))
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          ilowt(jlow) = ihigt(ihig)
          ihigt(ihig) = ihigt(jhig)
          jhig = jhig - 1
        Else
 
          ilow = ilowt(1)
          xmax = xdont(ilow)
          Do icrs = 2, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              iwrk = ilowt(icrs)
              xmax = xdont(iwrk)
              ilowt(icrs) = ilow
              ilow = iwrk
            End If
          End Do
          jlow = jlow - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to INTH.
      !
      Select Case (inth - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        inth = inth - jlow
        jlow = 0
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (unit=*,fmt=*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xdont(ihigt(1)) <= xdont(ihigt(2))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
          Else
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(3)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(3) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, inth
            jhig = jhig + 1
            ilowt(icrs) = ihigt(jhig)
          End Do
          jlow = inth
          Exit
          !
        Case (4 :)
          !
          !
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(ifin)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(ifin) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          !
          iwrk1 = ihigt(1)
          jlow = jlow + 1
          ilowt(jlow) = iwrk1
          xpiv = xdont(iwrk1) + 0.5 * (xdont(ihigt(ifin)) - xdont(iwrk1))
          !
          !  One takes values <= pivot to ILOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (jlow >= inth) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xdont(ihigt(1))
        ihig = 1
        Do icrs = 2, jhig
          If (xdont(ihigt(icrs)) < xmin) Then
            xmin = xdont(ihigt(icrs))
            ihig = icrs
          End If
        End Do
        !
        indnth = ihigt(ihig)
        Return
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        irngt(1) = ilowt(1)
        ilow = 1 + inth - jlow
        Do icrs = 2, inth
          iwrk = ilowt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, max(1, ilow), - 1
            If (xwrk < xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
          ilow = ilow + 1
        End Do
        !
        xwrk1 = xdont(irngt(inth))
        ilow = 2 * inth - jlow
        Do icrs = inth + 1, jlow
          If (xdont(ilowt(icrs)) < xwrk1) Then
            xwrk = xdont(ilowt(icrs))
            Do idcr = inth - 1, max(1, ilow), - 1
              If (xwrk >= xdont(irngt(idcr))) Exit
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ilowt(icrs)
            xwrk1 = xdont(irngt(inth))
          End If
          ilow = ilow + 1
        End Do
        !
        indnth = irngt(inth)
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
 
        imil = (jlow + 1) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ilowt(imil)) < xdont(ilowt(1))) Then
          iwrk = ilowt(1)
          ilowt(1) = ilowt(imil)
          ilowt(imil) = iwrk
        End If
        If (xdont(ilowt(imil)) > xdont(ilowt(ifin))) Then
          iwrk = ilowt(ifin)
          ilowt(ifin) = ilowt(imil)
          ilowt(imil) = iwrk
          If (xdont(ilowt(imil)) < xdont(ilowt(1))) Then
            iwrk = ilowt(1)
            ilowt(1) = ilowt(imil)
            ilowt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xdont(ilowt(1)) + real(inth, sp) / real(jlow + inth, sp) * &
                (xdont(ilowt(ifin)) - xdont(ilowt(1)))
 
        !
        !  One takes values > XPIV to IHIGT
        !
        jhig = 0
        jlow = 0
        !
        If (xdont(ilowt(ifin)) > xpiv) Then
          icrs = 0
          Do
            icrs = icrs + 1
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ilowt(icrs)) <= xpiv) Then
                jlow = jlow + 1
                ilowt(jlow) = ilowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = 1, ifin
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to find maximum of the 1:INTH set
    !
 
    iwrk1 = ilowt(1)
    xwrk1 = xdont(iwrk1)
    Do icrs = 1 + 1, inth
      iwrk = ilowt(icrs)
      xwrk = xdont(iwrk)
      If (xwrk > xwrk1) Then
        xwrk1 = xwrk
        iwrk1 = iwrk
      End If
    End Do
    indnth = iwrk1
    Return
    !
    !
  End Function r_indnth
 
  Function i_indnth (XDONT, NORD) Result (INDNTH)
    !  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then finds the maximum of this set.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4) :: INDNTH
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Integer(kind = i4) :: XPIV, XWRK, XWRK1, XMIN, XMAX
    !
    Integer(kind = i4), Dimension (NORD) :: IRNGT
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
    !
    ndon = SIZE (xdont)
    inth = nord
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (inth == 1) indnth = 1
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      ilowt(1) = 2
      ihigt(1) = 1
    Else
      ilowt(1) = 1
      ihigt(1) = 2
    End If
    !
    If (ndon < 3) Then
      If (inth == 1) indnth = ilowt(1)
      If (inth == 2) indnth = ihigt(1)
      Return
    End If
    !
    If (xdont(3) < xdont(ihigt(1))) Then
      ihigt(2) = ihigt(1)
      If (xdont(3) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = 3
      Else
        ihigt(1) = 3
      End If
    Else
      ihigt(2) = 3
    End If
    !
    If (ndon < 4) Then
      If (inth == 1) indnth = ilowt(1)
      If (inth == 2) indnth = ihigt(1)
      If (inth == 3) indnth = ihigt(2)
      Return
    End If
    !
    If (xdont(ndon) < xdont(ihigt(1))) Then
      ihigt(3) = ihigt(2)
      ihigt(2) = ihigt(1)
      If (xdont(ndon) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = ndon
      Else
        ihigt(1) = ndon
      End If
    Else
      ihigt(3) = ndon
    End If
    !
    If (ndon < 5) Then
      If (inth == 1) indnth = ilowt(1)
      If (inth == 2) indnth = ihigt(1)
      If (inth == 3) indnth = ihigt(2)
      If (inth == 4) indnth = ihigt(3)
      Return
    End If
    !
 
    jlow = 1
    jhig = 3
    xpiv = xdont(ilowt(1)) + int(real(2 * inth, sp) / real(ndon + inth, sp), i4) * &
            (xdont(ihigt(3)) - xdont(ilowt(1)))
    If (xpiv >= xdont(ihigt(1))) Then
      xpiv = xdont(ilowt(1)) + int(real(2 * inth, sp) / real(ndon + inth, sp), i4) * &
              (xdont(ihigt(2)) - xdont(ilowt(1)))
      If (xpiv >= xdont(ihigt(1))) &
              xpiv = xdont(ilowt(1)) + int(real(2 * inth, sp) / real(ndon + inth, sp), i4) * &
                      (xdont(ihigt(1)) - xdont(ilowt(1)))
    End If
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the IHIGT array as soon as we have more
    !  than enough values in ILOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= inth) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            ilowt(jlow) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= inth) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            ilowt(jlow) = icrs
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to INTH
        !
        If (inth > jlow) Then
          xmin = xdont(ihigt(1))
          ihig = 1
          Do icrs = 2, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              xmin = xdont(ihigt(icrs))
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          ilowt(jlow) = ihigt(ihig)
          ihigt(ihig) = ihigt(jhig)
          jhig = jhig - 1
        Else
 
          ilow = ilowt(1)
          xmax = xdont(ilow)
          Do icrs = 2, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              iwrk = ilowt(icrs)
              xmax = xdont(iwrk)
              ilowt(icrs) = ilow
              ilow = iwrk
            End If
          End Do
          jlow = jlow - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to INTH.
      !
      Select Case (inth - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        inth = inth - jlow
        jlow = 0
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (unit=*,fmt=*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xdont(ihigt(1)) <= xdont(ihigt(2))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
          Else
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(3)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(3) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, inth
            jhig = jhig + 1
            ilowt(icrs) = ihigt(jhig)
          End Do
          jlow = inth
          Exit
          !
        Case (4 :)
          !
          !
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(ifin)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(ifin) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          !
          iwrk1 = ihigt(1)
          jlow = jlow + 1
          ilowt(jlow) = iwrk1
          xpiv = xdont(iwrk1) + (xdont(ihigt(ifin)) - xdont(iwrk1)) / 2
          !
          !  One takes values <= pivot to ILOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (jlow >= inth) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xdont(ihigt(1))
        ihig = 1
        Do icrs = 2, jhig
          If (xdont(ihigt(icrs)) < xmin) Then
            xmin = xdont(ihigt(icrs))
            ihig = icrs
          End If
        End Do
        !
        indnth = ihigt(ihig)
        Return
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        irngt(1) = ilowt(1)
        ilow = 1 + inth - jlow
        Do icrs = 2, inth
          iwrk = ilowt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, max(1, ilow), - 1
            If (xwrk < xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
          ilow = ilow + 1
        End Do
        !
        xwrk1 = xdont(irngt(inth))
        ilow = 2 * inth - jlow
        Do icrs = inth + 1, jlow
          If (xdont(ilowt(icrs)) < xwrk1) Then
            xwrk = xdont(ilowt(icrs))
            Do idcr = inth - 1, max(1, ilow), - 1
              If (xwrk >= xdont(irngt(idcr))) Exit
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ilowt(icrs)
            xwrk1 = xdont(irngt(inth))
          End If
          ilow = ilow + 1
        End Do
        !
        indnth = irngt(inth)
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
 
        imil = (jlow + 1) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ilowt(imil)) < xdont(ilowt(1))) Then
          iwrk = ilowt(1)
          ilowt(1) = ilowt(imil)
          ilowt(imil) = iwrk
        End If
        If (xdont(ilowt(imil)) > xdont(ilowt(ifin))) Then
          iwrk = ilowt(ifin)
          ilowt(ifin) = ilowt(imil)
          ilowt(imil) = iwrk
          If (xdont(ilowt(imil)) < xdont(ilowt(1))) Then
            iwrk = ilowt(1)
            ilowt(1) = ilowt(imil)
            ilowt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xdont(ilowt(1)) + int(real(inth, sp) / real(jlow + inth, sp), i4) * &
                (xdont(ilowt(ifin)) - xdont(ilowt(1)))
 
        !
        !  One takes values > XPIV to IHIGT
        !
        jhig = 0
        jlow = 0
        !
        If (xdont(ilowt(ifin)) > xpiv) Then
          icrs = 0
          Do
            icrs = icrs + 1
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ilowt(icrs)) <= xpiv) Then
                jlow = jlow + 1
                ilowt(jlow) = ilowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = 1, ifin
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to find maximum of the 1:INTH set
    !
 
    iwrk1 = ilowt(1)
    xwrk1 = xdont(iwrk1)
    Do icrs = 1 + 1, inth
      iwrk = ilowt(icrs)
      xwrk = xdont(iwrk)
      If (xwrk > xwrk1) Then
        xwrk1 = xwrk
        iwrk1 = iwrk
      End If
    End Do
    indnth = iwrk1
    Return
    !
    !
  End Function i_indnth
 
  Subroutine d_inspar (XDONT, NORD)
    !  Sorts partially XDONT, bringing the NORD lowest values at the
    !  begining of the array
    ! __________________________________________________________
    !  This subroutine uses insertion sort, limiting insertion
    !  to the first NORD values. It does not use any work array
    !  and is faster when NORD is very small (2-5), but worst case
    !  behavior can happen fairly probably (initially inverse sorted)
    !  In many cases, the refined quicksort method is faster.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (InOut) :: xdont
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    real(kind = dp) :: xwrk, xwrk1
    !
    Integer(kind = i4) :: ICRS, IDCR
    !
    Do icrs = 2, nord
      xwrk = xdont(icrs)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk >= xdont(idcr)) Exit
        xdont(idcr + 1) = xdont(idcr)
      End Do
      xdont(idcr + 1) = xwrk
    End Do
    !
    xwrk1 = xdont(nord)
    Do icrs = nord + 1, SIZE (xdont)
      If (xdont(icrs) < xwrk1) Then
        xwrk = xdont(icrs)
        xdont(icrs) = xwrk1
        Do idcr = nord - 1, 1, - 1
          If (xwrk >= xdont(idcr)) Exit
          xdont(idcr + 1) = xdont(idcr)
        End Do
        xdont(idcr + 1) = xwrk
        xwrk1 = xdont(nord)
      End If
    End Do
    !
    !
  End Subroutine d_inspar
 
  Subroutine r_inspar (XDONT, NORD)
    !  Sorts partially XDONT, bringing the NORD lowest values at the
    !  begining of the array
    ! __________________________________________________________
    !  This subroutine uses insertion sort, limiting insertion
    !  to the first NORD values. It does not use any work array
    !  and is faster when NORD is very small (2-5), but worst case
    !  behavior can happen fairly probably (initially inverse sorted)
    !  In many cases, the refined quicksort method is faster.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (InOut) :: xdont
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Real(kind = sp) :: xwrk, xwrk1
    !
    Integer(kind = i4) :: ICRS, IDCR
    !
    Do icrs = 2, nord
      xwrk = xdont(icrs)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk >= xdont(idcr)) Exit
        xdont(idcr + 1) = xdont(idcr)
      End Do
      xdont(idcr + 1) = xwrk
    End Do
    !
    xwrk1 = xdont(nord)
    Do icrs = nord + 1, SIZE (xdont)
      If (xdont(icrs) < xwrk1) Then
        xwrk = xdont(icrs)
        xdont(icrs) = xwrk1
        Do idcr = nord - 1, 1, - 1
          If (xwrk >= xdont(idcr)) Exit
          xdont(idcr + 1) = xdont(idcr)
        End Do
        xdont(idcr + 1) = xwrk
        xwrk1 = xdont(nord)
      End If
    End Do
    !
    !
  End Subroutine r_inspar
 
  Subroutine i_inspar (XDONT, NORD)
    !  Sorts partially XDONT, bringing the NORD lowest values at the
    !  begining of the array
    ! __________________________________________________________
    !  This subroutine uses insertion sort, limiting insertion
    !  to the first NORD values. It does not use any work array
    !  and is faster when NORD is very small (2-5), but worst case
    !  behavior can happen fairly probably (initially inverse sorted)
    !  In many cases, the refined quicksort method is faster.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (InOut) :: XDONT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Integer(kind = i4) :: XWRK, XWRK1
    !
    Integer(kind = i4) :: ICRS, IDCR
    !
    Do icrs = 2, nord
      xwrk = xdont(icrs)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk >= xdont(idcr)) Exit
        xdont(idcr + 1) = xdont(idcr)
      End Do
      xdont(idcr + 1) = xwrk
    End Do
    !
    xwrk1 = xdont(nord)
    Do icrs = nord + 1, SIZE (xdont)
      If (xdont(icrs) < xwrk1) Then
        xwrk = xdont(icrs)
        xdont(icrs) = xwrk1
        Do idcr = nord - 1, 1, - 1
          If (xwrk >= xdont(idcr)) Exit
          xdont(idcr + 1) = xdont(idcr)
        End Do
        xdont(idcr + 1) = xwrk
        xwrk1 = xdont(nord)
      End If
    End Do
    !
    !
  End Subroutine i_inspar
 
  Subroutine d_inssor (XDONT)
    !  Sorts XDONT into increasing order (Insertion sort)
    ! __________________________________________________________
    !  This subroutine uses insertion sort. It does not use any
    !  work array and is faster when XDONT is of very small size
    !  (< 20), or already almost sorted, but worst case behavior
    !  can happen fairly probably (initially inverse sorted).
    !  In many cases, the quicksort or merge sort method is faster.
    !  Michel Olagnon - Apr. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (InOut) :: xdont
    ! __________________________________________________________
    real(Kind = dp) :: xwrk, xmin
    !
    ! __________________________________________________________
    !
    Integer(kind = i4) :: ICRS, IDCR, NDON
    !
    ndon = Size (xdont)
    !
    ! We first bring the minimum to the first location in the array.
    ! That way, we will have a "guard", and when looking for the
    ! right place to insert a value, no loop test is necessary.
    !
    If (xdont(1) < xdont(ndon)) Then
      xmin = xdont(1)
    Else
      xmin = xdont(ndon)
      xdont(ndon) = xdont(1)
    end if
    Do idcr = ndon - 1, 2, -1
      xwrk = xdont(idcr)
      IF (xwrk < xmin) Then
        xdont(idcr) = xmin
        xmin = xwrk
      End If
    End Do
    xdont(1) = xmin
    !
    ! The first value is now the minimum
    ! Loop over the array, and when a value is smaller than
    ! the previous one, loop down to insert it at its right place.
    !
    Do icrs = 3, ndon
      xwrk = xdont(icrs)
      idcr = icrs - 1
      If (xwrk < xdont(idcr)) Then
        xdont(icrs) = xdont(idcr)
        idcr = idcr - 1
        Do
          If (xwrk >= xdont(idcr)) Exit
          xdont(idcr + 1) = xdont(idcr)
          idcr = idcr - 1
        End Do
        xdont(idcr + 1) = xwrk
      End If
    End Do
    !
    Return
    !
  End Subroutine d_inssor
 
  Subroutine r_inssor (XDONT)
    !  Sorts XDONT into increasing order (Insertion sort)
    ! __________________________________________________________
    !  This subroutine uses insertion sort. It does not use any
    !  work array and is faster when XDONT is of very small size
    !  (< 20), or already almost sorted, but worst case behavior
    !  can happen fairly probably (initially inverse sorted).
    !  In many cases, the quicksort or merge sort method is faster.
    !  Michel Olagnon - Apr. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (InOut) :: xdont
    ! __________________________________________________________
    Real(kind = sp) :: xwrk, xmin
    !
    ! __________________________________________________________
    !
    Integer(kind = i4) :: ICRS, IDCR, NDON
    !
    ndon = Size (xdont)
    !
    ! We first bring the minimum to the first location in the array.
    ! That way, we will have a "guard", and when looking for the
    ! right place to insert a value, no loop test is necessary.
    !
    If (xdont(1) < xdont(ndon)) Then
      xmin = xdont(1)
    Else
      xmin = xdont(ndon)
      xdont(ndon) = xdont(1)
    end if
    Do idcr = ndon - 1, 2, -1
      xwrk = xdont(idcr)
      IF (xwrk < xmin) Then
        xdont(idcr) = xmin
        xmin = xwrk
      End If
    End Do
    xdont(1) = xmin
    !
    ! The first value is now the minimum
    ! Loop over the array, and when a value is smaller than
    ! the previous one, loop down to insert it at its right place.
    !
    Do icrs = 3, ndon
      xwrk = xdont(icrs)
      idcr = icrs - 1
      If (xwrk < xdont(idcr)) Then
        xdont(icrs) = xdont(idcr)
        idcr = idcr - 1
        Do
          If (xwrk >= xdont(idcr)) Exit
          xdont(idcr + 1) = xdont(idcr)
          idcr = idcr - 1
        End Do
        xdont(idcr + 1) = xwrk
      End If
    End Do
    !
    Return
    !
  End Subroutine r_inssor
 
  Subroutine i_inssor (XDONT)
    !  Sorts XDONT into increasing order (Insertion sort)
    ! __________________________________________________________
    !  This subroutine uses insertion sort. It does not use any
    !  work array and is faster when XDONT is of very small size
    !  (< 20), or already almost sorted, but worst case behavior
    !  can happen fairly probably (initially inverse sorted).
    !  In many cases, the quicksort or merge sort method is faster.
    !  Michel Olagnon - Apr. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (InOut) :: XDONT
    ! __________________________________________________________
    Integer(kind = i4) :: XWRK, XMIN
    !
    ! __________________________________________________________
    !
    Integer(kind = i4) :: ICRS, IDCR, NDON
    !
    ndon = Size (xdont)
    !
    ! We first bring the minimum to the first location in the array.
    ! That way, we will have a "guard", and when looking for the
    ! right place to insert a value, no loop test is necessary.
    !
    If (xdont(1) < xdont(ndon)) Then
      xmin = xdont(1)
    Else
      xmin = xdont(ndon)
      xdont(ndon) = xdont(1)
    end if
    Do idcr = ndon - 1, 2, -1
      xwrk = xdont(idcr)
      IF (xwrk < xmin) Then
        xdont(idcr) = xmin
        xmin = xwrk
      End If
    End Do
    xdont(1) = xmin
    !
    ! The first value is now the minimum
    ! Loop over the array, and when a value is smaller than
    ! the previous one, loop down to insert it at its right place.
    !
    Do icrs = 3, ndon
      xwrk = xdont(icrs)
      idcr = icrs - 1
      If (xwrk < xdont(idcr)) Then
        xdont(icrs) = xdont(idcr)
        idcr = idcr - 1
        Do
          If (xwrk >= xdont(idcr)) Exit
          xdont(idcr + 1) = xdont(idcr)
          idcr = idcr - 1
        End Do
        xdont(idcr + 1) = xwrk
      End If
    End Do
    !
    Return
    !
  End Subroutine i_inssor
 
  Subroutine c_inssor (XDONT)
    !  Sorts XDONT into increasing order (Insertion sort)
    ! __________________________________________________________
    !  This subroutine uses insertion sort. It does not use any
    !  work array and is faster when XDONT is of very small size
    !  (< 20), or already almost sorted, but worst case behavior
    !  can happen fairly probably (initially inverse sorted).
    !  In many cases, the quicksort or merge sort method is faster.
    !  Michel Olagnon - Apr. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    ! __________________________________________________________
    character(*), Dimension (:), Intent (InOut) :: XDONT
    ! __________________________________________________________
    character(len(XDONT)) :: XWRK, XMIN
    !
    ! __________________________________________________________
    !
    Integer(kind = i4) :: ICRS, IDCR, NDON
    !
    ndon = Size (xdont)
    !
    ! We first bring the minimum to the first location in the array.
    ! That way, we will have a "guard", and when looking for the
    ! right place to insert a value, no loop test is necessary.
    !
    If (xdont(1) < xdont(ndon)) Then
      xmin = xdont(1)
    Else
      xmin = xdont(ndon)
      xdont(ndon) = xdont(1)
    end if
    Do idcr = ndon - 1, 2, -1
      xwrk = xdont(idcr)
      IF (xwrk < xmin) Then
        xdont(idcr) = xmin
        xmin = xwrk
      End If
    End Do
    xdont(1) = xmin
    !
    ! The first value is now the minimum
    ! Loop over the array, and when a value is smaller than
    ! the previous one, loop down to insert it at its right place.
    !
    Do icrs = 3, ndon
      xwrk = xdont(icrs)
      idcr = icrs - 1
      If (xwrk < xdont(idcr)) Then
        xdont(icrs) = xdont(idcr)
        idcr = idcr - 1
        Do
          If (xwrk >= xdont(idcr)) Exit
          xdont(idcr + 1) = xdont(idcr)
          idcr = idcr - 1
        End Do
        xdont(idcr + 1) = xwrk
      End If
    End Do
    !
    Return
    !
  End Subroutine c_inssor
 
  Function d_median (XDONT) Result (median)
    !  Return median value of XDONT
    !  If even number of data, average of the two "medians".
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then finds the maximum of this set.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(Kind = dp), Dimension (:), Intent (In) :: xdont
    real(Kind = dp) :: median
    ! __________________________________________________________
    real(Kind = dp), Dimension (SIZE(XDONT)) :: xlowt, xhigt
    real(Kind = dp) :: xpiv, xwrk, xwrk1, xwrk2, xwrk3, xmin, xmax
    !!
    Logical :: IFODD
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG!, NORD
    Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR!, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
    !
    ndon = SIZE (xdont)
    inth = ndon / 2 + 1
    ifodd = (2 * inth == ndon + 1)
    !
    !    First loop is used to fill-in XLOWT, XHIGT at the same time
    !
    If (ndon < 3) Then
      If (ndon > 0) median = 0.5 * (xdont(1) + xdont(ndon))
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      xlowt(1) = xdont(2)
      xhigt(1) = xdont(1)
    Else
      xlowt(1) = xdont(1)
      xhigt(1) = xdont(2)
    End If
    !
    !
    If (xdont(3) < xhigt(1)) Then
      xhigt(2) = xhigt(1)
      If (xdont(3) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(3)
      Else
        xhigt(1) = xdont(3)
      End If
    Else
      xhigt(2) = xdont(3)
    End If
    !
    If (ndon < 4) Then ! 3 values
      median = xhigt(1)
      Return
    End If
    !
    If (xdont(ndon) < xhigt(1)) Then
      xhigt(3) = xhigt(2)
      xhigt(2) = xhigt(1)
      If (xdont(ndon) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(ndon)
      Else
        xhigt(1) = xdont(ndon)
      End If
    Else
      If (xdont(ndon) < xhigt(2)) Then
        xhigt(3) = xhigt(2)
        xhigt(2) = xdont(ndon)
      Else
        xhigt(3) = xdont(ndon)
      End If
    End If
    !
    If (ndon < 5) Then ! 4 values
      median = 0.5 * (xhigt(1) + xhigt(2))
      Return
    End If
    !
    jlow = 1
    jhig = 3
    xpiv = xlowt(1) + 2.0 * (xhigt(3) - xlowt(1)) / 3.0
    If (xpiv >= xhigt(1)) Then
      xpiv = xlowt(1) + 2.0 * (xhigt(2) - xlowt(1)) / 3.0
      If (xpiv >= xhigt(1)) xpiv = xlowt(1) + 2.0 * (xhigt(1) - xlowt(1)) / 3.0
    End If
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the XHIGT array as soon as we have more
    !  than enough values in XLOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to INTH
        !
        If (inth > jlow) Then
          xmin = xhigt(1)
          ihig = 1
          Do icrs = 2, jhig
            If (xhigt(icrs) < xmin) Then
              xmin = xhigt(icrs)
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          xlowt(jlow) = xhigt(ihig)
          xhigt(ihig) = xhigt(jhig)
          jhig = jhig - 1
        Else
 
          xmax = xlowt(jlow)
          jlow = jlow - 1
          Do icrs = 1, jlow
            If (xlowt(icrs) > xmax) Then
              xwrk = xmax
              xmax = xlowt(icrs)
              xlowt(icrs) = xwrk
            End If
          End Do
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to INTH.
      !
      Select Case (inth - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        inth = inth - jlow
        jlow = 0
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (unit=*,fmt=*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xhigt(1) <= xhigt(2)) Then
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
          Else
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(3)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(3) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, inth
            jhig = jhig + 1
            xlowt(icrs) = xhigt(jhig)
          End Do
          jlow = inth
          Exit
          !
        Case (4 :)
          !
          !
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(ifin)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(ifin) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          !
          xwrk1 = xhigt(1)
          jlow = jlow + 1
          xlowt(jlow) = xwrk1
          xpiv = xwrk1 + 0.5 * (xhigt(ifin) - xwrk1)
          !
          !  One takes values <= pivot to XLOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
              If (jlow >= inth) Exit
            Else
              jhig = jhig + 1
              xhigt(jhig) = xhigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xhigt(1)
        Do icrs = 2, jhig
          If (xhigt(icrs) < xmin) Then
            xmin = xhigt(icrs)
          End If
        End Do
        !
        jlow = jlow + 1
        xlowt(jlow) = xmin
        Exit
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        IF (ifodd) THEN
          jhig = jlow - inth + 1
        Else
          jhig = jlow - inth + 2
        end if
        xhigt(1) = xlowt(1)
        Do icrs = 2, jhig
          xwrk = xlowt(icrs)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk < xhigt(idcr)) Then
              xhigt(idcr + 1) = xhigt(idcr)
            Else
              Exit
            End If
          End Do
          xhigt(idcr + 1) = xwrk
        End Do
        !
        Do icrs = jhig + 1, jlow
          If (xlowt(icrs) > xhigt(1)) Then
            xwrk = xlowt(icrs)
            Do idcr = 2, jhig
              If (xwrk >= xhigt(idcr)) Then
                xhigt(idcr - 1) = xhigt(idcr)
              else
                exit
              end if
            End Do
            xhigt(idcr - 1) = xwrk
          End If
        End Do
        !
        IF (ifodd) THEN
          median = xhigt(1)
        Else
          median = 0.5 * (xhigt(1) + xhigt(2))
        end if
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
 
        imil = (jlow + 1) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xlowt(imil) < xlowt(1)) Then
          xwrk = xlowt(1)
          xlowt(1) = xlowt(imil)
          xlowt(imil) = xwrk
        End If
        If (xlowt(imil) > xlowt(ifin)) Then
          xwrk = xlowt(ifin)
          xlowt(ifin) = xlowt(imil)
          xlowt(imil) = xwrk
          If (xlowt(imil) < xlowt(1)) Then
            xwrk = xlowt(1)
            xlowt(1) = xlowt(imil)
            xlowt(imil) = xwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xlowt(1) + real(inth, dp) / real(jlow + inth, dp) * &
                (xlowt(ifin) - xlowt(1))
 
        !
        !  One takes values > XPIV to XHIGT
        !
        jhig = 0
        jlow = 0
        !
        If (xlowt(ifin) > xpiv) Then
          icrs = 0
          Do
            icrs = icrs + 1
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xlowt(icrs) <= xpiv) Then
                jlow = jlow + 1
                xlowt(jlow) = xlowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = 1, ifin
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xlowt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to find maximum of the 1:INTH set
    !
    if (ifodd) then
      median = maxval(xlowt(1 : inth))
    else
      xwrk = max(xlowt(1), xlowt(2))
      xwrk1 = min(xlowt(1), xlowt(2))
      DO icrs = 3, inth
        IF (xlowt(icrs) > xwrk1) THEN
          IF (xlowt(icrs) > xwrk) THEN
            xwrk1 = xwrk
            xwrk = xlowt(icrs)
          Else
            xwrk1 = xlowt(icrs)
          end if
        end if
      ENDDO
      median = 0.5 * (xwrk + xwrk1)
    end if
    Return
    !
  End Function d_median
 
  Function r_median (XDONT) Result (median)
    !  Return median value of XDONT
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then finds the maximum of this set.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Real(kind = sp) :: median
    ! __________________________________________________________
    Real(kind = sp), Dimension (SIZE(XDONT)) :: xlowt, xhigt
    Real(kind = sp) :: xpiv, xwrk, xwrk1, xwrk2, xwrk3, xmin, xmax
    !!
    Logical :: IFODD
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG!, NORD
    Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR!, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
    !
    ndon = SIZE (xdont)
    inth = ndon / 2 + 1
    ifodd = (2 * inth == ndon + 1)
    !
    !    First loop is used to fill-in XLOWT, XHIGT at the same time
    !
    If (ndon < 3) Then
      If (ndon > 0) median = 0.5 * (xdont(1) + xdont(ndon))
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      xlowt(1) = xdont(2)
      xhigt(1) = xdont(1)
    Else
      xlowt(1) = xdont(1)
      xhigt(1) = xdont(2)
    End If
    !
    !
    If (xdont(3) < xhigt(1)) Then
      xhigt(2) = xhigt(1)
      If (xdont(3) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(3)
      Else
        xhigt(1) = xdont(3)
      End If
    Else
      xhigt(2) = xdont(3)
    End If
    !
    If (ndon < 4) Then ! 3 values
      median = xhigt(1)
      Return
    End If
    !
    If (xdont(ndon) < xhigt(1)) Then
      xhigt(3) = xhigt(2)
      xhigt(2) = xhigt(1)
      If (xdont(ndon) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(ndon)
      Else
        xhigt(1) = xdont(ndon)
      End If
    Else
      If (xdont(ndon) < xhigt(2)) Then
        xhigt(3) = xhigt(2)
        xhigt(2) = xdont(ndon)
      Else
        xhigt(3) = xdont(ndon)
      End If
    End If
    !
    If (ndon < 5) Then ! 4 values
      median = 0.5 * (xhigt(1) + xhigt(2))
      Return
    End If
    !
    jlow = 1
    jhig = 3
    xpiv = xlowt(1) + 2.0 * (xhigt(3) - xlowt(1)) / 3.0
    If (xpiv >= xhigt(1)) Then
      xpiv = xlowt(1) + 2.0 * (xhigt(2) - xlowt(1)) / 3.0
      If (xpiv >= xhigt(1)) xpiv = xlowt(1) + 2.0 * (xhigt(1) - xlowt(1)) / 3.0
    End If
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the XHIGT array as soon as we have more
    !  than enough values in XLOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to INTH
        !
        If (inth > jlow) Then
          xmin = xhigt(1)
          ihig = 1
          Do icrs = 2, jhig
            If (xhigt(icrs) < xmin) Then
              xmin = xhigt(icrs)
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          xlowt(jlow) = xhigt(ihig)
          xhigt(ihig) = xhigt(jhig)
          jhig = jhig - 1
        Else
 
          xmax = xlowt(jlow)
          jlow = jlow - 1
          Do icrs = 1, jlow
            If (xlowt(icrs) > xmax) Then
              xwrk = xmax
              xmax = xlowt(icrs)
              xlowt(icrs) = xwrk
            End If
          End Do
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to INTH.
      !
      Select Case (inth - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        inth = inth - jlow
        jlow = 0
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (unit=*,fmt=*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xhigt(1) <= xhigt(2)) Then
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
          Else
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(3)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(3) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, inth
            jhig = jhig + 1
            xlowt(icrs) = xhigt(jhig)
          End Do
          jlow = inth
          Exit
          !
        Case (4 :)
          !
          !
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(ifin)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(ifin) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          !
          xwrk1 = xhigt(1)
          jlow = jlow + 1
          xlowt(jlow) = xwrk1
          xpiv = xwrk1 + 0.5 * (xhigt(ifin) - xwrk1)
          !
          !  One takes values <= pivot to XLOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
              If (jlow >= inth) Exit
            Else
              jhig = jhig + 1
              xhigt(jhig) = xhigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xhigt(1)
        Do icrs = 2, jhig
          If (xhigt(icrs) < xmin) Then
            xmin = xhigt(icrs)
          End If
        End Do
        !
        jlow = jlow + 1
        xlowt(jlow) = xmin
        Exit
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        IF (ifodd) THEN
          jhig = jlow - inth + 1
        Else
          jhig = jlow - inth + 2
        end if
        xhigt(1) = xlowt(1)
        Do icrs = 2, jhig
          xwrk = xlowt(icrs)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk < xhigt(idcr)) Then
              xhigt(idcr + 1) = xhigt(idcr)
            Else
              Exit
            End If
          End Do
          xhigt(idcr + 1) = xwrk
        End Do
        !
        Do icrs = jhig + 1, jlow
          If (xlowt(icrs) > xhigt(1)) Then
            xwrk = xlowt(icrs)
            Do idcr = 2, jhig
              If (xwrk >= xhigt(idcr)) Then
                xhigt(idcr - 1) = xhigt(idcr)
              else
                exit
              end if
            End Do
            xhigt(idcr - 1) = xwrk
          End If
        End Do
        !
        IF (ifodd) THEN
          median = xhigt(1)
        Else
          median = 0.5 * (xhigt(1) + xhigt(2))
        end if
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
 
        imil = (jlow + 1) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xlowt(imil) < xlowt(1)) Then
          xwrk = xlowt(1)
          xlowt(1) = xlowt(imil)
          xlowt(imil) = xwrk
        End If
        If (xlowt(imil) > xlowt(ifin)) Then
          xwrk = xlowt(ifin)
          xlowt(ifin) = xlowt(imil)
          xlowt(imil) = xwrk
          If (xlowt(imil) < xlowt(1)) Then
            xwrk = xlowt(1)
            xlowt(1) = xlowt(imil)
            xlowt(imil) = xwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xlowt(1) + real(inth, sp) / real(jlow + inth, sp) * &
                (xlowt(ifin) - xlowt(1))
 
        !
        !  One takes values > XPIV to XHIGT
        !
        jhig = 0
        jlow = 0
        !
        If (xlowt(ifin) > xpiv) Then
          icrs = 0
          Do
            icrs = icrs + 1
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xlowt(icrs) <= xpiv) Then
                jlow = jlow + 1
                xlowt(jlow) = xlowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = 1, ifin
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xlowt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to find maximum of the 1:INTH set
    !
    if (ifodd) then
      median = maxval(xlowt(1 : inth))
    else
      xwrk = max(xlowt(1), xlowt(2))
      xwrk1 = min(xlowt(1), xlowt(2))
      DO icrs = 3, inth
        IF (xlowt(icrs) > xwrk1) THEN
          IF (xlowt(icrs) > xwrk) THEN
            xwrk1 = xwrk
            xwrk = xlowt(icrs)
          Else
            xwrk1 = xlowt(icrs)
          end if
        end if
      ENDDO
      median = 0.5 * (xwrk + xwrk1)
    end if
    Return
    !
  End Function r_median
 
  Function i_median (XDONT) Result (median)
    !  Return median value of XDONT
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then finds the maximum of this set.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4) :: median
    ! __________________________________________________________
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: XLOWT, XHIGT
    Integer(kind = i4) :: XPIV, XWRK, XWRK1, XWRK2, XWRK3, XMIN, XMAX
    !!
    Logical :: IFODD
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG!, NORD
    Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR!, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
    !
    ndon = SIZE (xdont)
    inth = ndon / 2 + 1
    ifodd = (2 * inth == ndon + 1)
    !
    !    First loop is used to fill-in XLOWT, XHIGT at the same time
    !
    If (ndon < 3) Then
      If (ndon > 0) median = (xdont(1) + xdont(ndon)) / 2
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      xlowt(1) = xdont(2)
      xhigt(1) = xdont(1)
    Else
      xlowt(1) = xdont(1)
      xhigt(1) = xdont(2)
    End If
    !
    !
    If (xdont(3) < xhigt(1)) Then
      xhigt(2) = xhigt(1)
      If (xdont(3) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(3)
      Else
        xhigt(1) = xdont(3)
      End If
    Else
      xhigt(2) = xdont(3)
    End If
    !
    If (ndon < 4) Then ! 3 values
      median = xhigt(1)
      Return
    End If
    !
    If (xdont(ndon) < xhigt(1)) Then
      xhigt(3) = xhigt(2)
      xhigt(2) = xhigt(1)
      If (xdont(ndon) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(ndon)
      Else
        xhigt(1) = xdont(ndon)
      End If
    Else
      If (xdont(ndon) < xhigt(2)) Then
        xhigt(3) = xhigt(2)
        xhigt(2) = xdont(ndon)
      Else
        xhigt(3) = xdont(ndon)
      End If
    End If
    !
    If (ndon < 5) Then ! 4 values
      median = (xhigt(1) + xhigt(2)) / 2
      Return
    End If
    !
    jlow = 1
    jhig = 3
    xpiv = xlowt(1) + 2 * (xhigt(3) - xlowt(1)) / 3
    If (xpiv >= xhigt(1)) Then
      xpiv = xlowt(1) + 2 * (xhigt(2) - xlowt(1)) / 3
      If (xpiv >= xhigt(1)) xpiv = xlowt(1) + 2 * (xhigt(1) - xlowt(1)) / 3
    End If
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the XHIGT array as soon as we have more
    !  than enough values in XLOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to INTH
        !
        If (inth > jlow) Then
          xmin = xhigt(1)
          ihig = 1
          Do icrs = 2, jhig
            If (xhigt(icrs) < xmin) Then
              xmin = xhigt(icrs)
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          xlowt(jlow) = xhigt(ihig)
          xhigt(ihig) = xhigt(jhig)
          jhig = jhig - 1
        Else
 
          xmax = xlowt(jlow)
          jlow = jlow - 1
          Do icrs = 1, jlow
            If (xlowt(icrs) > xmax) Then
              xwrk = xmax
              xmax = xlowt(icrs)
              xlowt(icrs) = xwrk
            End If
          End Do
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to INTH.
      !
      Select Case (inth - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        inth = inth - jlow
        jlow = 0
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (unit=*,fmt=*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xhigt(1) <= xhigt(2)) Then
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
          Else
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(3)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(3) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, inth
            jhig = jhig + 1
            xlowt(icrs) = xhigt(jhig)
          End Do
          jlow = inth
          Exit
          !
        Case (4 :)
          !
          !
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(ifin)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(ifin) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          !
          xwrk1 = xhigt(1)
          jlow = jlow + 1
          xlowt(jlow) = xwrk1
          xpiv = xwrk1 + (xhigt(ifin) - xwrk1) / 2
          !
          !  One takes values <= pivot to XLOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
              If (jlow >= inth) Exit
            Else
              jhig = jhig + 1
              xhigt(jhig) = xhigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xhigt(1)
        Do icrs = 2, jhig
          If (xhigt(icrs) < xmin) Then
            xmin = xhigt(icrs)
          End If
        End Do
        !
        jlow = jlow + 1
        xlowt(jlow) = xmin
        Exit
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        IF (ifodd) THEN
          jhig = jlow - inth + 1
        Else
          jhig = jlow - inth + 2
        end if
        xhigt(1) = xlowt(1)
        Do icrs = 2, jhig
          xwrk = xlowt(icrs)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk < xhigt(idcr)) Then
              xhigt(idcr + 1) = xhigt(idcr)
            Else
              Exit
            End If
          End Do
          xhigt(idcr + 1) = xwrk
        End Do
        !
        Do icrs = jhig + 1, jlow
          If (xlowt(icrs) > xhigt(1)) Then
            xwrk = xlowt(icrs)
            Do idcr = 2, jhig
              If (xwrk >= xhigt(idcr)) Then
                xhigt(idcr - 1) = xhigt(idcr)
              else
                exit
              end if
            End Do
            xhigt(idcr - 1) = xwrk
          End If
        End Do
        !
        IF (ifodd) THEN
          median = xhigt(1)
        Else
          median = (xhigt(1) + xhigt(2)) / 2
        end if
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
 
        imil = (jlow + 1) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xlowt(imil) < xlowt(1)) Then
          xwrk = xlowt(1)
          xlowt(1) = xlowt(imil)
          xlowt(imil) = xwrk
        End If
        If (xlowt(imil) > xlowt(ifin)) Then
          xwrk = xlowt(ifin)
          xlowt(ifin) = xlowt(imil)
          xlowt(imil) = xwrk
          If (xlowt(imil) < xlowt(1)) Then
            xwrk = xlowt(1)
            xlowt(1) = xlowt(imil)
            xlowt(imil) = xwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xlowt(1) + int(real(inth, sp) / real(jlow + inth, sp), i4) * &
                (xlowt(ifin) - xlowt(1))
 
        !
        !  One takes values > XPIV to XHIGT
        !
        jhig = 0
        jlow = 0
        !
        If (xlowt(ifin) > xpiv) Then
          icrs = 0
          Do
            icrs = icrs + 1
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xlowt(icrs) <= xpiv) Then
                jlow = jlow + 1
                xlowt(jlow) = xlowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = 1, ifin
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xlowt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to find maximum of the 1:INTH set
    !
    if (ifodd) then
      median = maxval(xlowt(1 : inth))
    else
      xwrk = max(xlowt(1), xlowt(2))
      xwrk1 = min(xlowt(1), xlowt(2))
      DO icrs = 3, inth
        IF (xlowt(icrs) > xwrk1) THEN
          IF (xlowt(icrs) > xwrk) THEN
            xwrk1 = xwrk
            xwrk = xlowt(icrs)
          Else
            xwrk1 = xlowt(icrs)
          end if
        end if
      ENDDO
      median = (xwrk + xwrk1) / 2
    end if
    Return
    !
  End Function i_median
 
  Subroutine d_mrgref (XVALT, IRNGT)
    !   Ranks array XVALT into index array IRNGT, using merge-sort
    ! __________________________________________________________
    !   This version is not optimized for performance, and is thus
    !   not as difficult to read as some other ones.
    !   Michel Olagnon - April 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xvalt
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    ! __________________________________________________________
    !
    Integer(kind = i4), Dimension (:), Allocatable :: JWRKT
    Integer(kind = i4) :: LMTNA, LMTNC
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    !
    nval = min(SIZE(xvalt), SIZE(irngt))
    If (nval <= 0) Then
      Return
    End If
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xvalt(iind - 1) <= xvalt(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    Allocate (jwrkt(1 : nval))
    lmtnc = 2
    lmtna = 2
    !
    !  Iteration. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      iwrk = 0
      !
      !   Loop on merges of A and B into C
      !
      Do
        iinda = iwrkf
        iwrkd = iwrkf + 1
        iwrkf = iinda + lmtnc
        jinda = iinda + lmtna
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iindb = jinda
        !
        !   Shortcut for the case when the max of A is smaller
        !   than the min of B (no need to do anything)
        !
        If (xvalt(irngt(jinda)) <= xvalt(irngt(jinda + 1))) Then
          iwrk = iwrkf
          cycle
        End If
        !
        !  One steps in the C subset, that we create in the final rank array
        !
        Do
          If (iwrk >= iwrkf) Then
            !
            !  Make a copy of the rank array for next iteration
            !
            irngt(iwrkd : iwrkf) = jwrkt(iwrkd : iwrkf)
            Exit
          End If
          !
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (iinda < jinda) Then
            If (iindb < iwrkf) Then
              If (xvalt(irngt(iinda + 1)) > xvalt(irngt(iindb + 1))) &
                      & Then
                iindb = iindb + 1
                jwrkt(iwrk) = irngt(iindb)
              Else
                iinda = iinda + 1
                jwrkt(iwrk) = irngt(iinda)
              End If
            Else
              !
              !  Only A still with unprocessed values
              !
              iinda = iinda + 1
              jwrkt(iwrk) = irngt(iinda)
            End If
          Else
            !
            !  Only B still with unprocessed values
            !
            irngt(iwrkd : iindb) = jwrkt(iwrkd : iindb)
            iwrk = iwrkf
            Exit
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    !  Clean up
    !
    Deallocate (jwrkt)
    Return
    !
  End Subroutine d_mrgref
 
  Subroutine r_mrgref (XVALT, IRNGT)
    !   Ranks array XVALT into index array IRNGT, using merge-sort
    ! __________________________________________________________
    !   This version is not optimized for performance, and is thus
    !   not as difficult to read as some other ones.
    !   Michel Olagnon - April 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xvalt
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    ! __________________________________________________________
    !
    Integer(kind = i4), Dimension (:), Allocatable :: JWRKT
    Integer(kind = i4) :: LMTNA, LMTNC
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    !
    nval = min(SIZE(xvalt), SIZE(irngt))
    If (nval <= 0) Then
      Return
    End If
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xvalt(iind - 1) <= xvalt(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    Allocate (jwrkt(1 : nval))
    lmtnc = 2
    lmtna = 2
    !
    !  Iteration. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      iwrk = 0
      !
      !   Loop on merges of A and B into C
      !
      Do
        iinda = iwrkf
        iwrkd = iwrkf + 1
        iwrkf = iinda + lmtnc
        jinda = iinda + lmtna
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iindb = jinda
        !
        !   Shortcut for the case when the max of A is smaller
        !   than the min of B (no need to do anything)
        !
        If (xvalt(irngt(jinda)) <= xvalt(irngt(jinda + 1))) Then
          iwrk = iwrkf
          cycle
        End If
        !
        !  One steps in the C subset, that we create in the final rank array
        !
        Do
          If (iwrk >= iwrkf) Then
            !
            !  Make a copy of the rank array for next iteration
            !
            irngt(iwrkd : iwrkf) = jwrkt(iwrkd : iwrkf)
            Exit
          End If
          !
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (iinda < jinda) Then
            If (iindb < iwrkf) Then
              If (xvalt(irngt(iinda + 1)) > xvalt(irngt(iindb + 1))) &
                      & Then
                iindb = iindb + 1
                jwrkt(iwrk) = irngt(iindb)
              Else
                iinda = iinda + 1
                jwrkt(iwrk) = irngt(iinda)
              End If
            Else
              !
              !  Only A still with unprocessed values
              !
              iinda = iinda + 1
              jwrkt(iwrk) = irngt(iinda)
            End If
          Else
            !
            !  Only B still with unprocessed values
            !
            irngt(iwrkd : iindb) = jwrkt(iwrkd : iindb)
            iwrk = iwrkf
            Exit
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    !  Clean up
    !
    Deallocate (jwrkt)
    Return
    !
  End Subroutine r_mrgref
 
  Subroutine i_mrgref (XVALT, IRNGT)
    !   Ranks array XVALT into index array IRNGT, using merge-sort
    ! __________________________________________________________
    !   This version is not optimized for performance, and is thus
    !   not as difficult to read as some other ones.
    !   Michel Olagnon - April 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XVALT
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    ! __________________________________________________________
    !
    Integer(kind = i4), Dimension (:), Allocatable :: JWRKT
    Integer(kind = i4) :: LMTNA, LMTNC
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    !
    nval = min(SIZE(xvalt), SIZE(irngt))
    If (nval <= 0) Then
      Return
    End If
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xvalt(iind - 1) <= xvalt(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    Allocate (jwrkt(1 : nval))
    lmtnc = 2
    lmtna = 2
    !
    !  Iteration. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      iwrk = 0
      !
      !   Loop on merges of A and B into C
      !
      Do
        iinda = iwrkf
        iwrkd = iwrkf + 1
        iwrkf = iinda + lmtnc
        jinda = iinda + lmtna
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iindb = jinda
        !
        !   Shortcut for the case when the max of A is smaller
        !   than the min of B (no need to do anything)
        !
        If (xvalt(irngt(jinda)) <= xvalt(irngt(jinda + 1))) Then
          iwrk = iwrkf
          cycle
        End If
        !
        !  One steps in the C subset, that we create in the final rank array
        !
        Do
          If (iwrk >= iwrkf) Then
            !
            !  Make a copy of the rank array for next iteration
            !
            irngt(iwrkd : iwrkf) = jwrkt(iwrkd : iwrkf)
            Exit
          End If
          !
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (iinda < jinda) Then
            If (iindb < iwrkf) Then
              If (xvalt(irngt(iinda + 1)) > xvalt(irngt(iindb + 1))) &
                      & Then
                iindb = iindb + 1
                jwrkt(iwrk) = irngt(iindb)
              Else
                iinda = iinda + 1
                jwrkt(iwrk) = irngt(iinda)
              End If
            Else
              !
              !  Only A still with unprocessed values
              !
              iinda = iinda + 1
              jwrkt(iwrk) = irngt(iinda)
            End If
          Else
            !
            !  Only B still with unprocessed values
            !
            irngt(iwrkd : iindb) = jwrkt(iwrkd : iindb)
            iwrk = iwrkf
            Exit
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    !  Clean up
    !
    Deallocate (jwrkt)
    Return
    !
  End Subroutine i_mrgref
 
  Subroutine d_mrgrnk (XDONT, IRNGT)
    ! __________________________________________________________
    !   MRGRNK = Merge-sort ranking of an array
    !   For performance reasons, the first 2 passes are taken
    !   out of the standard loop, and use dedicated coding.
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    ! __________________________________________________________
    real(kind = dp) :: xvala, xvalb
    !
    Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
    Integer(kind = i4) :: LMTNA, LMTNC, IRNG1, IRNG2
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    !
    nval = min(SIZE(xdont), SIZE(irngt))
    Select Case (nval)
    Case (: 0)
      Return
    Case (1)
      irngt(1) = 1
      Return
    Case Default
 
    End Select
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xdont(iind - 1) <= xdont(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    lmtna = 2
    lmtnc = 4
    !
    !  First iteration. The length of the ordered subsets goes from 2 to 4
    !
    Do
      If (nval <= 2) Exit
      !
      !   Loop on merges of A and B into C
      !
      Do iwrkd = 0, nval - 1, 4
        If ((iwrkd + 4) > nval) Then
          If ((iwrkd + 2) >= nval) Exit
          !
          !   1 2 3
          !
          If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) Exit
          !
          !   1 3 2
          !
          If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
            irng2 = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irng2
            !
            !   3 1 2
            !
          Else
            irng1 = irngt(iwrkd + 1)
            irngt(iwrkd + 1) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irng1
          End If
          If (.true.) Exit   ! Exit ! JM
        End If
        !
        !   1 2 3 4
        !
        If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) cycle
        !
        !   1 3 x x
        !
        If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 2) = irngt(iwrkd + 3)
          If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
            !   1 3 2 4
            irngt(iwrkd + 3) = irng2
          Else
            !   1 3 4 2
            irngt(iwrkd + 3) = irngt(iwrkd + 4)
            irngt(iwrkd + 4) = irng2
          End If
          !
          !   3 x x x
          !
        Else
          irng1 = irngt(iwrkd + 1)
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 1) = irngt(iwrkd + 3)
          If (xdont(irng1) <= xdont(irngt(iwrkd + 4))) Then
            irngt(iwrkd + 2) = irng1
            If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
              !   3 1 2 4
              irngt(iwrkd + 3) = irng2
            Else
              !   3 1 4 2
              irngt(iwrkd + 3) = irngt(iwrkd + 4)
              irngt(iwrkd + 4) = irng2
            End If
          Else
            !   3 4 1 2
            irngt(iwrkd + 2) = irngt(iwrkd + 4)
            irngt(iwrkd + 3) = irng1
            irngt(iwrkd + 4) = irng2
          End If
        End If
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 4
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    !  Iteration loop. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      !
      !   Loop on merges of A and B into C
      !
      Do
        iwrk = iwrkf
        iwrkd = iwrkf + 1
        jinda = iwrkf + lmtna
        iwrkf = iwrkf + lmtnc
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iinda = 1
        iindb = jinda + 1
        !
        !   Shortcut for the case when the max of A is smaller
        !   than the min of B. This line may be activated when the
        !   initial set is already close to sorted.
        !
        !          IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
        !
        !  One steps in the C subset, that we build in the final rank array
        !
        !  Make a copy of the rank array for the merge iteration
        !
        jwrkt(1 : lmtna) = irngt(iwrkd : jinda)
        !
        xvala = xdont(jwrkt(iinda))
        xvalb = xdont(irngt(iindb))
        !
        Do
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (xvala > xvalb) Then
            irngt(iwrk) = irngt(iindb)
            iindb = iindb + 1
            If (iindb > iwrkf) Then
              !  Only A still with unprocessed values
              irngt(iwrk + 1 : iwrkf) = jwrkt(iinda : lmtna)
              Exit
            End If
            xvalb = xdont(irngt(iindb))
          Else
            irngt(iwrk) = jwrkt(iinda)
            iinda = iinda + 1
            If (iinda > lmtna) exit! Only B still with unprocessed values
            xvala = xdont(jwrkt(iinda))
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    Return
    !
  End Subroutine d_mrgrnk
 
  Subroutine r_mrgrnk (XDONT, IRNGT)
    ! __________________________________________________________
    !   MRGRNK = Merge-sort ranking of an array
    !   For performance reasons, the first 2 passes are taken
    !   out of the standard loop, and use dedicated coding.
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    ! __________________________________________________________
    Real(kind = sp) :: xvala, xvalb
    !
    Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
    Integer(kind = i4) :: LMTNA, LMTNC, IRNG1, IRNG2
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    !
    nval = min(SIZE(xdont), SIZE(irngt))
    Select Case (nval)
    Case (: 0)
      Return
    Case (1)
      irngt(1) = 1
      Return
    Case Default
 
    End Select
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xdont(iind - 1) <= xdont(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    lmtna = 2
    lmtnc = 4
    !
    !  First iteration. The length of the ordered subsets goes from 2 to 4
    !
    Do
      If (nval <= 2) Exit
      !
      !   Loop on merges of A and B into C
      !
      Do iwrkd = 0, nval - 1, 4
        If ((iwrkd + 4) > nval) Then
          If ((iwrkd + 2) >= nval) Exit
          !
          !   1 2 3
          !
          If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) Exit
          !
          !   1 3 2
          !
          If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
            irng2 = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irng2
            !
            !   3 1 2
            !
          Else
            irng1 = irngt(iwrkd + 1)
            irngt(iwrkd + 1) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irng1
          End If
          If (.true.) Exit   ! Exit ! JM
        End If
        !
        !   1 2 3 4
        !
        If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) cycle
        !
        !   1 3 x x
        !
        If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 2) = irngt(iwrkd + 3)
          If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
            !   1 3 2 4
            irngt(iwrkd + 3) = irng2
          Else
            !   1 3 4 2
            irngt(iwrkd + 3) = irngt(iwrkd + 4)
            irngt(iwrkd + 4) = irng2
          End If
          !
          !   3 x x x
          !
        Else
          irng1 = irngt(iwrkd + 1)
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 1) = irngt(iwrkd + 3)
          If (xdont(irng1) <= xdont(irngt(iwrkd + 4))) Then
            irngt(iwrkd + 2) = irng1
            If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
              !   3 1 2 4
              irngt(iwrkd + 3) = irng2
            Else
              !   3 1 4 2
              irngt(iwrkd + 3) = irngt(iwrkd + 4)
              irngt(iwrkd + 4) = irng2
            End If
          Else
            !   3 4 1 2
            irngt(iwrkd + 2) = irngt(iwrkd + 4)
            irngt(iwrkd + 3) = irng1
            irngt(iwrkd + 4) = irng2
          End If
        End If
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 4
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    !  Iteration loop. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      !
      !   Loop on merges of A and B into C
      !
      Do
        iwrk = iwrkf
        iwrkd = iwrkf + 1
        jinda = iwrkf + lmtna
        iwrkf = iwrkf + lmtnc
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iinda = 1
        iindb = jinda + 1
        !
        !   Shortcut for the case when the max of A is smaller
        !   than the min of B. This line may be activated when the
        !   initial set is already close to sorted.
        !
        !          IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
        !
        !  One steps in the C subset, that we build in the final rank array
        !
        !  Make a copy of the rank array for the merge iteration
        !
        jwrkt(1 : lmtna) = irngt(iwrkd : jinda)
        !
        xvala = xdont(jwrkt(iinda))
        xvalb = xdont(irngt(iindb))
        !
        Do
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (xvala > xvalb) Then
            irngt(iwrk) = irngt(iindb)
            iindb = iindb + 1
            If (iindb > iwrkf) Then
              !  Only A still with unprocessed values
              irngt(iwrk + 1 : iwrkf) = jwrkt(iinda : lmtna)
              Exit
            End If
            xvalb = xdont(irngt(iindb))
          Else
            irngt(iwrk) = jwrkt(iinda)
            iinda = iinda + 1
            If (iinda > lmtna) exit! Only B still with unprocessed values
            xvala = xdont(jwrkt(iinda))
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    Return
    !
  End Subroutine r_mrgrnk
 
  Subroutine i_mrgrnk (XDONT, IRNGT)
    ! __________________________________________________________
    !   MRGRNK = Merge-sort ranking of an array
    !   For performance reasons, the first 2 passes are taken
    !   out of the standard loop, and use dedicated coding.
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    ! __________________________________________________________
    Integer(kind = i4) :: XVALA, XVALB
    !
    Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
    Integer(kind = i4) :: LMTNA, LMTNC, IRNG1, IRNG2
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    !
    nval = min(SIZE(xdont), SIZE(irngt))
    Select Case (nval)
    Case (: 0)
      Return
    Case (1)
      irngt(1) = 1
      Return
    Case Default
 
    End Select
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xdont(iind - 1) <= xdont(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    lmtna = 2
    lmtnc = 4
    !
    !  First iteration. The length of the ordered subsets goes from 2 to 4
    !
    Do
      If (nval <= 2) Exit
      !
      !   Loop on merges of A and B into C
      !
      Do iwrkd = 0, nval - 1, 4
        If ((iwrkd + 4) > nval) Then
          If ((iwrkd + 2) >= nval) Exit
          !
          !   1 2 3
          !
          If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) Exit
          !
          !   1 3 2
          !
          If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
            irng2 = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irng2
            !
            !   3 1 2
            !
          Else
            irng1 = irngt(iwrkd + 1)
            irngt(iwrkd + 1) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irng1
          End If
          If (.true.) Exit   ! Exit ! JM
        End If
        !
        !   1 2 3 4
        !
        If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) cycle
        !
        !   1 3 x x
        !
        If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 2) = irngt(iwrkd + 3)
          If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
            !   1 3 2 4
            irngt(iwrkd + 3) = irng2
          Else
            !   1 3 4 2
            irngt(iwrkd + 3) = irngt(iwrkd + 4)
            irngt(iwrkd + 4) = irng2
          End If
          !
          !   3 x x x
          !
        Else
          irng1 = irngt(iwrkd + 1)
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 1) = irngt(iwrkd + 3)
          If (xdont(irng1) <= xdont(irngt(iwrkd + 4))) Then
            irngt(iwrkd + 2) = irng1
            If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
              !   3 1 2 4
              irngt(iwrkd + 3) = irng2
            Else
              !   3 1 4 2
              irngt(iwrkd + 3) = irngt(iwrkd + 4)
              irngt(iwrkd + 4) = irng2
            End If
          Else
            !   3 4 1 2
            irngt(iwrkd + 2) = irngt(iwrkd + 4)
            irngt(iwrkd + 3) = irng1
            irngt(iwrkd + 4) = irng2
          End If
        End If
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 4
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    !  Iteration loop. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      !
      !   Loop on merges of A and B into C
      !
      Do
        iwrk = iwrkf
        iwrkd = iwrkf + 1
        jinda = iwrkf + lmtna
        iwrkf = iwrkf + lmtnc
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iinda = 1
        iindb = jinda + 1
        !
        !   Shortcut for the case when the max of A is smaller
        !   than the min of B. This line may be activated when the
        !   initial set is already close to sorted.
        !
        !          IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
        !
        !  One steps in the C subset, that we build in the final rank array
        !
        !  Make a copy of the rank array for the merge iteration
        !
        jwrkt(1 : lmtna) = irngt(iwrkd : jinda)
        !
        xvala = xdont(jwrkt(iinda))
        xvalb = xdont(irngt(iindb))
        !
        Do
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (xvala > xvalb) Then
            irngt(iwrk) = irngt(iindb)
            iindb = iindb + 1
            If (iindb > iwrkf) Then
              !  Only A still with unprocessed values
              irngt(iwrk + 1 : iwrkf) = jwrkt(iinda : lmtna)
              Exit
            End If
            xvalb = xdont(irngt(iindb))
          Else
            irngt(iwrk) = jwrkt(iinda)
            iinda = iinda + 1
            If (iinda > lmtna) exit! Only B still with unprocessed values
            xvala = xdont(jwrkt(iinda))
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    Return
    !
  End Subroutine i_mrgrnk
 
  Subroutine c_mrgrnk (XDONT, IRNGT)
    ! __________________________________________________________
    !   MRGRNK = Merge-sort ranking of an array
    !   For performance reasons, the first 2 passes are taken
    !   out of the standard loop, and use dedicated coding.
    ! __________________________________________________________
    ! __________________________________________________________
    character(*), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    ! __________________________________________________________
    character(len(XDONT)) :: XVALA, XVALB
    !
    Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
    Integer(kind = i4) :: LMTNA, LMTNC, IRNG1, IRNG2
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    !
    nval = min(SIZE(xdont), SIZE(irngt))
    Select Case (nval)
    Case (: 0)
      Return
    Case (1)
      irngt(1) = 1
      Return
    Case Default
 
    End Select
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xdont(iind - 1) <= xdont(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    lmtna = 2
    lmtnc = 4
    !
    !  First iteration. The length of the ordered subsets goes from 2 to 4
    !
    Do
      If (nval <= 2) Exit
      !
      !   Loop on merges of A and B into C
      !
      Do iwrkd = 0, nval - 1, 4
        If ((iwrkd + 4) > nval) Then
          If ((iwrkd + 2) >= nval) Exit
          !
          !   1 2 3
          !
          If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) Exit
          !
          !   1 3 2
          !
          If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
            irng2 = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irng2
            !
            !   3 1 2
            !
          Else
            irng1 = irngt(iwrkd + 1)
            irngt(iwrkd + 1) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irng1
          End If
          If (.true.) Exit   ! Exit ! JM
        End If
        !
        !   1 2 3 4
        !
        If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) cycle
        !
        !   1 3 x x
        !
        If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 2) = irngt(iwrkd + 3)
          If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
            !   1 3 2 4
            irngt(iwrkd + 3) = irng2
          Else
            !   1 3 4 2
            irngt(iwrkd + 3) = irngt(iwrkd + 4)
            irngt(iwrkd + 4) = irng2
          End If
          !
          !   3 x x x
          !
        Else
          irng1 = irngt(iwrkd + 1)
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 1) = irngt(iwrkd + 3)
          If (xdont(irng1) <= xdont(irngt(iwrkd + 4))) Then
            irngt(iwrkd + 2) = irng1
            If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
              !   3 1 2 4
              irngt(iwrkd + 3) = irng2
            Else
              !   3 1 4 2
              irngt(iwrkd + 3) = irngt(iwrkd + 4)
              irngt(iwrkd + 4) = irng2
            End If
          Else
            !   3 4 1 2
            irngt(iwrkd + 2) = irngt(iwrkd + 4)
            irngt(iwrkd + 3) = irng1
            irngt(iwrkd + 4) = irng2
          End If
        End If
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 4
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    !  Iteration loop. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      !
      !   Loop on merges of A and B into C
      !
      Do
        iwrk = iwrkf
        iwrkd = iwrkf + 1
        jinda = iwrkf + lmtna
        iwrkf = iwrkf + lmtnc
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iinda = 1
        iindb = jinda + 1
        !
        !   Shortcut for the case when the max of A is smaller
        !   than the min of B. This line may be activated when the
        !   initial set is already close to sorted.
        !
        !          IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
        !
        !  One steps in the C subset, that we build in the final rank array
        !
        !  Make a copy of the rank array for the merge iteration
        !
        jwrkt(1 : lmtna) = irngt(iwrkd : jinda)
        !
        xvala = xdont(jwrkt(iinda))
        xvalb = xdont(irngt(iindb))
        !
        Do
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (xvala > xvalb) Then
            irngt(iwrk) = irngt(iindb)
            iindb = iindb + 1
            If (iindb > iwrkf) Then
              !  Only A still with unprocessed values
              irngt(iwrk + 1 : iwrkf) = jwrkt(iinda : lmtna)
              Exit
            End If
            xvalb = xdont(irngt(iindb))
          Else
            irngt(iwrk) = jwrkt(iinda)
            iinda = iinda + 1
            If (iinda > lmtna) exit! Only B still with unprocessed values
            xvala = xdont(jwrkt(iinda))
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    Return
    !
  End Subroutine c_mrgrnk
 
  Subroutine d_mulcnt (XDONT, IMULT)
    !   MULCNT = Give for each array value its multiplicity
    !            (number of times that it appears in the array)
    ! __________________________________________________________
    !  Michel Olagnon - Mar. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IMULT
    ! __________________________________________________________
    !
    Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
    Integer(kind = i4), Dimension (Size(XDONT)) :: ICNTT
    Integer(kind = i4) :: ICRS
    ! __________________________________________________________
    Call uniinv (xdont, iwrkt)
    icntt = 0
    Do icrs = 1, Size(xdont)
      icntt(iwrkt(icrs)) = icntt(iwrkt(icrs)) + 1
    End Do
    Do icrs = 1, Size(xdont)
      imult(icrs) = icntt(iwrkt(icrs))
    End Do
 
    !
  End Subroutine d_mulcnt
 
  Subroutine r_mulcnt (XDONT, IMULT)
    !   MULCNT = Give for each array value its multiplicity
    !            (number of times that it appears in the array)
    ! __________________________________________________________
    !  Michel Olagnon - Mar. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IMULT
    ! __________________________________________________________
    !
    Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
    Integer(kind = i4), Dimension (Size(XDONT)) :: ICNTT
    Integer(kind = i4) :: ICRS
    ! __________________________________________________________
    Call uniinv (xdont, iwrkt)
    icntt = 0
    Do icrs = 1, Size(xdont)
      icntt(iwrkt(icrs)) = icntt(iwrkt(icrs)) + 1
    End Do
    Do icrs = 1, Size(xdont)
      imult(icrs) = icntt(iwrkt(icrs))
    End Do
 
    !
  End Subroutine r_mulcnt
 
  Subroutine i_mulcnt (XDONT, IMULT)
    !   MULCNT = Give for each array value its multiplicity
    !            (number of times that it appears in the array)
    ! __________________________________________________________
    !  Michel Olagnon - Mar. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4), Dimension (:), Intent (Out) :: IMULT
    ! __________________________________________________________
    !
    Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
    Integer(kind = i4), Dimension (Size(XDONT)) :: ICNTT
    Integer(kind = i4) :: ICRS
    ! __________________________________________________________
    Call uniinv (xdont, iwrkt)
    icntt = 0
    Do icrs = 1, Size(xdont)
      icntt(iwrkt(icrs)) = icntt(iwrkt(icrs)) + 1
    End Do
    Do icrs = 1, Size(xdont)
      imult(icrs) = icntt(iwrkt(icrs))
    End Do
 
    !
  End Subroutine i_mulcnt
 
  Subroutine d_rapknr (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD, in decreasing order.
    !  rapknr = (rnkpar backwards)
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values larger than the pivot
    !  (IHIGT), and the indices of values smaller than the pivot
    !  that we might still need later on (ILOWT). It iterates
    !  until it can bring the number of values in IHIGT to
    !  exactly NORD, and then uses an insertion sort to rank
    !  this set, since it is supposedly small.
    !  Michel Olagnon - Feb. 2011
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    real(kind = dp) :: xpiv, xpiv0, xwrk, xwrk1, xmin, xmax
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
    !
    ndon = SIZE (xdont)
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (nord >= 1) irngt(1) = 1
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of high values.
    !
    If (xdont(2) < xdont(1)) Then
      ilowt(1) = 2
      ihigt(1) = 1
    Else
      ilowt(1) = 1
      ihigt(1) = 2
    End If
    !
    If (ndon < 3) Then
      If (nord >= 1) irngt(1) = ihigt(1)
      If (nord >= 2) irngt(2) = ilowt(1)
      Return
    End If
    ! ---
    If (xdont(3) > xdont(ilowt(1))) Then
      ilowt(2) = ilowt(1)
      If (xdont(3) > xdont(ihigt(1))) Then
        ilowt(1) = ihigt(1)
        ihigt(1) = 3
      Else
        ilowt(1) = 3
      End If
    Else
      ilowt(2) = 3
    End If
    ! ---
    If (ndon < 4) Then
      If (nord >= 1) irngt(1) = ihigt(1)
      If (nord >= 2) irngt(2) = ilowt(1)
      If (nord >= 3) irngt(3) = ilowt(2)
      Return
    End If
    !
    If (xdont(ndon) > xdont(ilowt(1))) Then
      ilowt(3) = ilowt(2)
      ilowt(2) = ilowt(1)
      If (xdont(ndon) > xdont(ihigt(1))) Then
        ilowt(1) = ihigt(1)
        ihigt(1) = ndon
      Else
        ilowt(1) = ndon
      End If
    Else
      if (xdont(ndon) > xdont(ilowt(2))) Then
        ilowt(3) = ilowt(2)
        ilowt(2) = ndon
      else
        ilowt(3) = ndon
      end if
    End If
    !
    If (ndon < 5) Then
      If (nord >= 1) irngt(1) = ihigt(1)
      If (nord >= 2) irngt(2) = ilowt(1)
      If (nord >= 3) irngt(3) = ilowt(2)
      If (nord >= 4) irngt(4) = ilowt(3)
      Return
    End If
    ! ---
    jdeb = 0
    ideb = jdeb + 1
    jhig = ideb
    jlow = 3
    xpiv = xdont(ihigt(ideb)) + real(2 * nord, dp) / real(ndon + nord, dp) * &
            (xdont(ilowt(3)) - xdont(ihigt(ideb)))
    If (xpiv >= xdont(ilowt(1))) Then
      xpiv = xdont(ihigt(ideb)) + real(2 * nord, dp) / real(ndon + nord, dp) * &
              (xdont(ilowt(2)) - xdont(ihigt(ideb)))
      If (xpiv >= xdont(ilowt(1))) &
              xpiv = xdont(ihigt(ideb)) + real(2 * nord, dp) / real(ndon + nord, dp) * &
                      (xdont(ilowt(1)) - xdont(ihigt(ideb)))
    End If
    xpiv0 = xpiv
    ! ---
    !  One puts values < pivot in the end and those >= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the ILOWT array as soon as we have more
    !  than enough values in IHIGT.
    !
    !
    If (xdont(ndon) < xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) < xpiv) Then
          If (icrs >= ndon) Exit
          jlow = jlow + 1
          ilowt(jlow) = icrs
        Else
          jhig = jhig + 1
          ihigt(jhig) = icrs
          If (jhig >= nord) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more low values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) >= xpiv) Then
            jhig = jhig + 1
            ihigt(jhig) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      ! ---
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) < xpiv) Then
          jlow = jlow + 1
          ilowt(jlow) = icrs
        Else
          jhig = jhig + 1
          ihigt(jhig) = icrs
          If (jhig >= nord) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) >= xpiv) Then
            If (icrs >= ndon) Exit
            jhig = jhig + 1
            ihigt(jhig) = icrs
          End If
        End Do
      End If
    End If
    ! ---
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      if (jhig == nord) Exit
      If (jhm2 == jhig .And. jlm2 == jlow) Then
        !
        !   We are oscillating. Perturbate by bringing JHIG closer by one
        !   to NORD
        !
        If (nord > jhig) Then
          xmax = xdont(ilowt(1))
          ilow = 1
          Do icrs = 2, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              xmax = xdont(ilowt(icrs))
              ilow = icrs
            End If
          End Do
          !
          jhig = jhig + 1
          ihigt(jhig) = ilowt(ilow)
          ilowt(ilow) = ilowt(jlow)
          jlow = jlow - 1
        Else
          ihig = ihigt(jhig)
          xmin = xdont(ihig)
          Do icrs = 1, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              iwrk = ihigt(icrs)
              xmin = xdont(iwrk)
              ihigt(icrs) = ihig
              ihig = iwrk
            End If
          End Do
          jhig = jhig - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      ! ---
      !   We try to bring the number of values in the high values set
      !   closer to NORD.
      !
      Select Case (nord - jhig)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        Select Case (jlow)
          !!!!!           CASE DEFAULT
          !!!!!              write (*,*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the low values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xdont(ilowt(1)) >= xdont(ilowt(2))) Then
            jhig = jhig + 1
            ihigt(jhig) = ilowt(1)
            jhig = jhig + 1
            ihigt(jhig) = ilowt(2)
          Else
            jhig = jhig + 1
            ihigt(jhig) = ilowt(2)
            jhig = jhig + 1
            ihigt(jhig) = ilowt(1)
          End If
          Exit
          ! ---
        Case (3)
          !
          !
          iwrk1 = ilowt(1)
          iwrk2 = ilowt(2)
          iwrk3 = ilowt(3)
          If (xdont(iwrk2) > xdont(iwrk1)) Then
            ilowt(1) = iwrk2
            ilowt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) < xdont(iwrk3)) Then
            ilowt(3) = iwrk2
            ilowt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) > xdont(ilowt(1))) Then
              ilowt(2) = ilowt(1)
              ilowt(1) = iwrk2
            End If
          End If
          jlow = 0
          Do icrs = jhig + 1, nord
            jlow = jlow + 1
            ihigt(icrs) = ilowt(jlow)
          End Do
          jhig = nord
          Exit
          ! ---
        Case (4 :)
          !
          !
          xpiv0 = xpiv
          ifin = jlow
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ilowt(1)
          iwrk2 = ilowt(2)
          iwrk3 = ilowt(ifin)
          If (xdont(iwrk2) > xdont(iwrk1)) Then
            ilowt(1) = iwrk2
            ilowt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) < xdont(iwrk3)) Then
            ilowt(ifin) = iwrk2
            ilowt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) > xdont(ihigt(1))) Then
              ilowt(2) = ilowt(1)
              ilowt(1) = iwrk2
            End If
          End If
          !
          jdeb = jhig
          nwrk = nord - jhig
          iwrk1 = ilowt(1)
          jhig = jhig + 1
          ihigt(jhig) = iwrk1
          xpiv = xdont(iwrk1) + real(nwrk, dp) / real(nord + nwrk, dp) * &
                  (xdont(ilowt(ifin)) - xdont(iwrk1))
          !
          !  One takes values >= pivot to IHIGT
          !  Again, 2 parts, one where we take care of the remaining
          !  low values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  high values in the end.
          ! ---
          jlow = 0
          Do icrs = 2, ifin
            If (xdont(ilowt(icrs)) >= xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (jhig >= nord) Exit
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) >= xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            End If
          End Do
        End Select
        ! ---
        !
      Case (1)
        !
        !  Only 1 value is missing in high part
        !
        xmax = xdont(ilowt(1))
        ilow = 1
        Do icrs = 2, jlow
          If (xdont(ilowt(icrs)) > xmax) Then
            xmax = xdont(ilowt(icrs))
            ilow = icrs
          End If
        End Do
        !
        jhig = jhig + 1
        ihigt(jhig) = ilowt(ilow)
        Exit
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        ! ---
        !
      Case (-5 : -1)
        !
        !  Only few values too many in high part
        !
        irngt(1) = ihigt(1)
        Do icrs = 2, nord
          iwrk = ihigt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk > xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
        End Do
        !
        xwrk1 = xdont(irngt(nord))
        Do icrs = nord + 1, jhig
          If (xdont(ihigt(icrs)) > xwrk1) Then
            xwrk = xdont(ihigt(icrs))
            Do idcr = nord - 1, 1, - 1
              If (xwrk <= xdont(irngt(idcr))) Exit
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ihigt(icrs)
            xwrk1 = xdont(irngt(nord))
          End If
        End Do
        !
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in high part
        ! ---
        ideb = jdeb + 1
        imil = (jhig + ideb) / 2
        ifin = jhig
        ! ---
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ihigt(imil)) > xdont(ihigt(ideb))) Then
          iwrk = ihigt(ideb)
          ihigt(ideb) = ihigt(imil)
          ihigt(imil) = iwrk
        End If
        If (xdont(ihigt(imil)) < xdont(ihigt(ifin))) Then
          iwrk = ihigt(ifin)
          ihigt(ifin) = ihigt(imil)
          ihigt(imil) = iwrk
          If (xdont(ihigt(imil)) > xdont(ihigt(ideb))) Then
            iwrk = ihigt(ideb)
            ihigt(ideb) = ihigt(imil)
            ihigt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        ! ---
        xpiv = xdont(ihigt(1)) + real(nord, sp) / real(jhig + nord, sp) * &
                (xdont(ihigt(ifin)) - xdont(ihigt(1)))
        If (jdeb > 0) Then
          If (xpiv <= xpiv0) &
                  xpiv = xpiv0 + real(2 * nord - jdeb, dp) / real(jhig + nord, dp) * &
                          (xdont(ihigt(ifin)) - xpiv0)
        Else
          ideb = 1
        End If
        !
        !  One takes values < XPIV to ILOWT
        !  However, we do not process the first values if we have been
        !  through the case when we did not have enough high values
        ! ---
        jlow = 0
        jhig = jdeb
        ! ---
        If (xdont(ihigt(ifin)) < xpiv) Then
          icrs = jdeb
          Do
            icrs = icrs + 1
            If (xdont(ihigt(icrs)) < xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (icrs >= ifin) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
              If (jhig >= nord) Exit
            End If
          End Do
          ! ---
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ihigt(icrs)) >= xpiv) Then
                jhig = jhig + 1
                ihigt(jhig) = ihigt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = ideb, ifin
            If (xdont(ihigt(icrs)) < xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
              If (jhig >= nord) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) >= xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    ! ---
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    irngt(1) = ihigt(1)
    Do icrs = 2, nord
      iwrk = ihigt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk > xdont(irngt(idcr))) Then
          irngt(idcr + 1) = irngt(idcr)
        Else
          Exit
        End If
      End Do
      irngt(idcr + 1) = iwrk
    End Do
    Return
    !
    !
  End Subroutine d_rapknr
 
  Subroutine r_rapknr (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD, in decreasing order.
    !  rapknr = (rnkpar backwards)
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values larger than the pivot
    !  (IHIGT), and the indices of values smaller than the pivot
    !  that we might still need later on (ILOWT). It iterates
    !  until it can bring the number of values in IHIGT to
    !  exactly NORD, and then uses an insertion sort to rank
    !  this set, since it is supposedly small.
    !  Michel Olagnon - Feb. 2011
    ! __________________________________________________________
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Real(kind = sp) :: xpiv, xpiv0, xwrk, xwrk1, xmin, xmax
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
    !
    ndon = SIZE (xdont)
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (nord >= 1) irngt(1) = 1
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of high values.
    !
    If (xdont(2) < xdont(1)) Then
      ilowt(1) = 2
      ihigt(1) = 1
    Else
      ilowt(1) = 1
      ihigt(1) = 2
    End If
    !
    If (ndon < 3) Then
      If (nord >= 1) irngt(1) = ihigt(1)
      If (nord >= 2) irngt(2) = ilowt(1)
      Return
    End If
    ! ---
    If (xdont(3) > xdont(ilowt(1))) Then
      ilowt(2) = ilowt(1)
      If (xdont(3) > xdont(ihigt(1))) Then
        ilowt(1) = ihigt(1)
        ihigt(1) = 3
      Else
        ilowt(1) = 3
      End If
    Else
      ilowt(2) = 3
    End If
    ! ---
    If (ndon < 4) Then
      If (nord >= 1) irngt(1) = ihigt(1)
      If (nord >= 2) irngt(2) = ilowt(1)
      If (nord >= 3) irngt(3) = ilowt(2)
      Return
    End If
    !
    If (xdont(ndon) > xdont(ilowt(1))) Then
      ilowt(3) = ilowt(2)
      ilowt(2) = ilowt(1)
      If (xdont(ndon) > xdont(ihigt(1))) Then
        ilowt(1) = ihigt(1)
        ihigt(1) = ndon
      Else
        ilowt(1) = ndon
      End If
    Else
      if (xdont(ndon) > xdont(ilowt(2))) Then
        ilowt(3) = ilowt(2)
        ilowt(2) = ndon
      else
        ilowt(3) = ndon
      end if
    End If
    !
    If (ndon < 5) Then
      If (nord >= 1) irngt(1) = ihigt(1)
      If (nord >= 2) irngt(2) = ilowt(1)
      If (nord >= 3) irngt(3) = ilowt(2)
      If (nord >= 4) irngt(4) = ilowt(3)
      Return
    End If
    ! ---
    jdeb = 0
    ideb = jdeb + 1
    jhig = ideb
    jlow = 3
    xpiv = xdont(ihigt(ideb)) + real(2 * nord, sp) / real(ndon + nord, sp) * &
            (xdont(ilowt(3)) - xdont(ihigt(ideb)))
    If (xpiv >= xdont(ilowt(1))) Then
      xpiv = xdont(ihigt(ideb)) + real(2 * nord, sp) / real(ndon + nord, sp) * &
              (xdont(ilowt(2)) - xdont(ihigt(ideb)))
      If (xpiv >= xdont(ilowt(1))) &
              xpiv = xdont(ihigt(ideb)) + real(2 * nord, sp) / real(ndon + nord, sp) * &
                      (xdont(ilowt(1)) - xdont(ihigt(ideb)))
    End If
    xpiv0 = xpiv
    ! ---
    !  One puts values < pivot in the end and those >= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the ILOWT array as soon as we have more
    !  than enough values in IHIGT.
    !
    !
    If (xdont(ndon) < xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) < xpiv) Then
          If (icrs >= ndon) Exit
          jlow = jlow + 1
          ilowt(jlow) = icrs
        Else
          jhig = jhig + 1
          ihigt(jhig) = icrs
          If (jhig >= nord) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more low values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) >= xpiv) Then
            jhig = jhig + 1
            ihigt(jhig) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      ! ---
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) < xpiv) Then
          jlow = jlow + 1
          ilowt(jlow) = icrs
        Else
          jhig = jhig + 1
          ihigt(jhig) = icrs
          If (jhig >= nord) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) >= xpiv) Then
            If (icrs >= ndon) Exit
            jhig = jhig + 1
            ihigt(jhig) = icrs
          End If
        End Do
      End If
    End If
    ! ---
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      if (jhig == nord) Exit
      If (jhm2 == jhig .And. jlm2 == jlow) Then
        !
        !   We are oscillating. Perturbate by bringing JHIG closer by one
        !   to NORD
        !
        If (nord > jhig) Then
          xmax = xdont(ilowt(1))
          ilow = 1
          Do icrs = 2, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              xmax = xdont(ilowt(icrs))
              ilow = icrs
            End If
          End Do
          !
          jhig = jhig + 1
          ihigt(jhig) = ilowt(ilow)
          ilowt(ilow) = ilowt(jlow)
          jlow = jlow - 1
        Else
          ihig = ihigt(jhig)
          xmin = xdont(ihig)
          Do icrs = 1, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              iwrk = ihigt(icrs)
              xmin = xdont(iwrk)
              ihigt(icrs) = ihig
              ihig = iwrk
            End If
          End Do
          jhig = jhig - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      ! ---
      !   We try to bring the number of values in the high values set
      !   closer to NORD.
      !
      Select Case (nord - jhig)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        Select Case (jlow)
          !!!!!           CASE DEFAULT
          !!!!!              write (*,*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the low values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xdont(ilowt(1)) >= xdont(ilowt(2))) Then
            jhig = jhig + 1
            ihigt(jhig) = ilowt(1)
            jhig = jhig + 1
            ihigt(jhig) = ilowt(2)
          Else
            jhig = jhig + 1
            ihigt(jhig) = ilowt(2)
            jhig = jhig + 1
            ihigt(jhig) = ilowt(1)
          End If
          Exit
          ! ---
        Case (3)
          !
          !
          iwrk1 = ilowt(1)
          iwrk2 = ilowt(2)
          iwrk3 = ilowt(3)
          If (xdont(iwrk2) > xdont(iwrk1)) Then
            ilowt(1) = iwrk2
            ilowt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) < xdont(iwrk3)) Then
            ilowt(3) = iwrk2
            ilowt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) > xdont(ilowt(1))) Then
              ilowt(2) = ilowt(1)
              ilowt(1) = iwrk2
            End If
          End If
          jlow = 0
          Do icrs = jhig + 1, nord
            jlow = jlow + 1
            ihigt(icrs) = ilowt(jlow)
          End Do
          jhig = nord
          Exit
          ! ---
        Case (4 :)
          !
          !
          xpiv0 = xpiv
          ifin = jlow
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ilowt(1)
          iwrk2 = ilowt(2)
          iwrk3 = ilowt(ifin)
          If (xdont(iwrk2) > xdont(iwrk1)) Then
            ilowt(1) = iwrk2
            ilowt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) < xdont(iwrk3)) Then
            ilowt(ifin) = iwrk2
            ilowt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) > xdont(ihigt(1))) Then
              ilowt(2) = ilowt(1)
              ilowt(1) = iwrk2
            End If
          End If
          !
          jdeb = jhig
          nwrk = nord - jhig
          iwrk1 = ilowt(1)
          jhig = jhig + 1
          ihigt(jhig) = iwrk1
          xpiv = xdont(iwrk1) + real(nwrk, sp) / real(nord + nwrk, sp) * &
                  (xdont(ilowt(ifin)) - xdont(iwrk1))
          !
          !  One takes values >= pivot to IHIGT
          !  Again, 2 parts, one where we take care of the remaining
          !  low values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  high values in the end.
          ! ---
          jlow = 0
          Do icrs = 2, ifin
            If (xdont(ilowt(icrs)) >= xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (jhig >= nord) Exit
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) >= xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            End If
          End Do
        End Select
        ! ---
        !
      Case (1)
        !
        !  Only 1 value is missing in high part
        !
        xmax = xdont(ilowt(1))
        ilow = 1
        Do icrs = 2, jlow
          If (xdont(ilowt(icrs)) > xmax) Then
            xmax = xdont(ilowt(icrs))
            ilow = icrs
          End If
        End Do
        !
        jhig = jhig + 1
        ihigt(jhig) = ilowt(ilow)
        Exit
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        ! ---
        !
      Case (-5 : -1)
        !
        !  Only few values too many in high part
        !
        irngt(1) = ihigt(1)
        Do icrs = 2, nord
          iwrk = ihigt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk > xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
        End Do
        !
        xwrk1 = xdont(irngt(nord))
        Do icrs = nord + 1, jhig
          If (xdont(ihigt(icrs)) > xwrk1) Then
            xwrk = xdont(ihigt(icrs))
            Do idcr = nord - 1, 1, - 1
              If (xwrk <= xdont(irngt(idcr))) Exit
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ihigt(icrs)
            xwrk1 = xdont(irngt(nord))
          End If
        End Do
        !
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in high part
        ! ---
        ideb = jdeb + 1
        imil = (jhig + ideb) / 2
        ifin = jhig
        ! ---
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ihigt(imil)) > xdont(ihigt(ideb))) Then
          iwrk = ihigt(ideb)
          ihigt(ideb) = ihigt(imil)
          ihigt(imil) = iwrk
        End If
        If (xdont(ihigt(imil)) < xdont(ihigt(ifin))) Then
          iwrk = ihigt(ifin)
          ihigt(ifin) = ihigt(imil)
          ihigt(imil) = iwrk
          If (xdont(ihigt(imil)) > xdont(ihigt(ideb))) Then
            iwrk = ihigt(ideb)
            ihigt(ideb) = ihigt(imil)
            ihigt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        ! ---
        xpiv = xdont(ihigt(1)) + real(nord, sp) / real(jhig + nord, sp) * &
                (xdont(ihigt(ifin)) - xdont(ihigt(1)))
        If (jdeb > 0) Then
          If (xpiv <= xpiv0) &
                  xpiv = xpiv0 + real(2 * nord - jdeb, sp) / real(jhig + nord, sp) * &
                          (xdont(ihigt(ifin)) - xpiv0)
        Else
          ideb = 1
        End If
        !
        !  One takes values < XPIV to ILOWT
        !  However, we do not process the first values if we have been
        !  through the case when we did not have enough high values
        ! ---
        jlow = 0
        jhig = jdeb
        ! ---
        If (xdont(ihigt(ifin)) < xpiv) Then
          icrs = jdeb
          Do
            icrs = icrs + 1
            If (xdont(ihigt(icrs)) < xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (icrs >= ifin) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
              If (jhig >= nord) Exit
            End If
          End Do
          ! ---
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ihigt(icrs)) >= xpiv) Then
                jhig = jhig + 1
                ihigt(jhig) = ihigt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = ideb, ifin
            If (xdont(ihigt(icrs)) < xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
              If (jhig >= nord) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) >= xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    ! ---
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    irngt(1) = ihigt(1)
    Do icrs = 2, nord
      iwrk = ihigt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk > xdont(irngt(idcr))) Then
          irngt(idcr + 1) = irngt(idcr)
        Else
          Exit
        End If
      End Do
      irngt(idcr + 1) = iwrk
    End Do
    Return
    !
    !
  End Subroutine r_rapknr
 
  Subroutine i_rapknr (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD, in decreasing order.
    !  rapknr = (rnkpar backwards)
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values larger than the pivot
    !  (IHIGT), and the indices of values smaller than the pivot
    !  that we might still need later on (ILOWT). It iterates
    !  until it can bring the number of values in IHIGT to
    !  exactly NORD, and then uses an insertion sort to rank
    !  this set, since it is supposedly small.
    !  Michel Olagnon - Feb. 2011
    ! __________________________________________________________
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Integer(kind = i4) :: XPIV, XPIV0, XWRK, XWRK1, XMIN, XMAX
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
    !
    ndon = SIZE (xdont)
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (nord >= 1) irngt(1) = 1
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of high values.
    !
    If (xdont(2) < xdont(1)) Then
      ilowt(1) = 2
      ihigt(1) = 1
    Else
      ilowt(1) = 1
      ihigt(1) = 2
    End If
    !
    If (ndon < 3) Then
      If (nord >= 1) irngt(1) = ihigt(1)
      If (nord >= 2) irngt(2) = ilowt(1)
      Return
    End If
    ! ---
    If (xdont(3) > xdont(ilowt(1))) Then
      ilowt(2) = ilowt(1)
      If (xdont(3) > xdont(ihigt(1))) Then
        ilowt(1) = ihigt(1)
        ihigt(1) = 3
      Else
        ilowt(1) = 3
      End If
    Else
      ilowt(2) = 3
    End If
    ! ---
    If (ndon < 4) Then
      If (nord >= 1) irngt(1) = ihigt(1)
      If (nord >= 2) irngt(2) = ilowt(1)
      If (nord >= 3) irngt(3) = ilowt(2)
      Return
    End If
    !
    If (xdont(ndon) > xdont(ilowt(1))) Then
      ilowt(3) = ilowt(2)
      ilowt(2) = ilowt(1)
      If (xdont(ndon) > xdont(ihigt(1))) Then
        ilowt(1) = ihigt(1)
        ihigt(1) = ndon
      Else
        ilowt(1) = ndon
      End If
    Else
      if (xdont(ndon) > xdont(ilowt(2))) Then
        ilowt(3) = ilowt(2)
        ilowt(2) = ndon
      else
        ilowt(3) = ndon
      end if
    End If
    !
    If (ndon < 5) Then
      If (nord >= 1) irngt(1) = ihigt(1)
      If (nord >= 2) irngt(2) = ilowt(1)
      If (nord >= 3) irngt(3) = ilowt(2)
      If (nord >= 4) irngt(4) = ilowt(3)
      Return
    End If
    ! ---
    jdeb = 0
    ideb = jdeb + 1
    jhig = ideb
    jlow = 3
    xpiv = xdont(ihigt(ideb)) + int(real(2 * nord, sp) / real(ndon + nord, sp), i4) * &
            (xdont(ilowt(3)) - xdont(ihigt(ideb)))
    If (xpiv >= xdont(ilowt(1))) Then
      xpiv = xdont(ihigt(ideb)) + int(real(2 * nord, sp) / real(ndon + nord, sp), i4) * &
              (xdont(ilowt(2)) - xdont(ihigt(ideb)))
      If (xpiv >= xdont(ilowt(1))) &
              xpiv = xdont(ihigt(ideb)) + int(real(2 * nord, sp) / real(ndon + nord, sp), i4) * &
                      (xdont(ilowt(1)) - xdont(ihigt(ideb)))
    End If
    xpiv0 = xpiv
    ! ---
    !  One puts values < pivot in the end and those >= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the ILOWT array as soon as we have more
    !  than enough values in IHIGT.
    !
    !
    If (xdont(ndon) < xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) < xpiv) Then
          If (icrs >= ndon) Exit
          jlow = jlow + 1
          ilowt(jlow) = icrs
        Else
          jhig = jhig + 1
          ihigt(jhig) = icrs
          If (jhig >= nord) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more low values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) >= xpiv) Then
            jhig = jhig + 1
            ihigt(jhig) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      ! ---
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) < xpiv) Then
          jlow = jlow + 1
          ilowt(jlow) = icrs
        Else
          jhig = jhig + 1
          ihigt(jhig) = icrs
          If (jhig >= nord) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) >= xpiv) Then
            If (icrs >= ndon) Exit
            jhig = jhig + 1
            ihigt(jhig) = icrs
          End If
        End Do
      End If
    End If
    ! ---
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      if (jhig == nord) Exit
      If (jhm2 == jhig .And. jlm2 == jlow) Then
        !
        !   We are oscillating. Perturbate by bringing JHIG closer by one
        !   to NORD
        !
        If (nord > jhig) Then
          xmax = xdont(ilowt(1))
          ilow = 1
          Do icrs = 2, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              xmax = xdont(ilowt(icrs))
              ilow = icrs
            End If
          End Do
          !
          jhig = jhig + 1
          ihigt(jhig) = ilowt(ilow)
          ilowt(ilow) = ilowt(jlow)
          jlow = jlow - 1
        Else
          ihig = ihigt(jhig)
          xmin = xdont(ihig)
          Do icrs = 1, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              iwrk = ihigt(icrs)
              xmin = xdont(iwrk)
              ihigt(icrs) = ihig
              ihig = iwrk
            End If
          End Do
          jhig = jhig - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      ! ---
      !   We try to bring the number of values in the high values set
      !   closer to NORD.
      !
      Select Case (nord - jhig)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        Select Case (jlow)
          !!!!!           CASE DEFAULT
          !!!!!              write (*,*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the low values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xdont(ilowt(1)) >= xdont(ilowt(2))) Then
            jhig = jhig + 1
            ihigt(jhig) = ilowt(1)
            jhig = jhig + 1
            ihigt(jhig) = ilowt(2)
          Else
            jhig = jhig + 1
            ihigt(jhig) = ilowt(2)
            jhig = jhig + 1
            ihigt(jhig) = ilowt(1)
          End If
          Exit
          ! ---
        Case (3)
          !
          !
          iwrk1 = ilowt(1)
          iwrk2 = ilowt(2)
          iwrk3 = ilowt(3)
          If (xdont(iwrk2) > xdont(iwrk1)) Then
            ilowt(1) = iwrk2
            ilowt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) < xdont(iwrk3)) Then
            ilowt(3) = iwrk2
            ilowt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) > xdont(ilowt(1))) Then
              ilowt(2) = ilowt(1)
              ilowt(1) = iwrk2
            End If
          End If
          jlow = 0
          Do icrs = jhig + 1, nord
            jlow = jlow + 1
            ihigt(icrs) = ilowt(jlow)
          End Do
          jhig = nord
          Exit
          ! ---
        Case (4 :)
          !
          !
          xpiv0 = xpiv
          ifin = jlow
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ilowt(1)
          iwrk2 = ilowt(2)
          iwrk3 = ilowt(ifin)
          If (xdont(iwrk2) > xdont(iwrk1)) Then
            ilowt(1) = iwrk2
            ilowt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) < xdont(iwrk3)) Then
            ilowt(ifin) = iwrk2
            ilowt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) > xdont(ihigt(1))) Then
              ilowt(2) = ilowt(1)
              ilowt(1) = iwrk2
            End If
          End If
          !
          jdeb = jhig
          nwrk = nord - jhig
          iwrk1 = ilowt(1)
          jhig = jhig + 1
          ihigt(jhig) = iwrk1
          xpiv = xdont(iwrk1) + int(real(nwrk, sp) / real(nord + nwrk, sp), i4) * &
                  (xdont(ilowt(ifin)) - xdont(iwrk1))
          !
          !  One takes values >= pivot to IHIGT
          !  Again, 2 parts, one where we take care of the remaining
          !  low values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  high values in the end.
          ! ---
          jlow = 0
          Do icrs = 2, ifin
            If (xdont(ilowt(icrs)) >= xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (jhig >= nord) Exit
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) >= xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            End If
          End Do
        End Select
        ! ---
        !
      Case (1)
        !
        !  Only 1 value is missing in high part
        !
        xmax = xdont(ilowt(1))
        ilow = 1
        Do icrs = 2, jlow
          If (xdont(ilowt(icrs)) > xmax) Then
            xmax = xdont(ilowt(icrs))
            ilow = icrs
          End If
        End Do
        !
        jhig = jhig + 1
        ihigt(jhig) = ilowt(ilow)
        Exit
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        ! ---
        !
      Case (-5 : -1)
        !
        !  Only few values too many in high part
        !
        irngt(1) = ihigt(1)
        Do icrs = 2, nord
          iwrk = ihigt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk > xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
        End Do
        !
        xwrk1 = xdont(irngt(nord))
        Do icrs = nord + 1, jhig
          If (xdont(ihigt(icrs)) > xwrk1) Then
            xwrk = xdont(ihigt(icrs))
            Do idcr = nord - 1, 1, - 1
              If (xwrk <= xdont(irngt(idcr))) Exit
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ihigt(icrs)
            xwrk1 = xdont(irngt(nord))
          End If
        End Do
        !
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in high part
        ! ---
        ideb = jdeb + 1
        imil = (jhig + ideb) / 2
        ifin = jhig
        ! ---
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ihigt(imil)) > xdont(ihigt(ideb))) Then
          iwrk = ihigt(ideb)
          ihigt(ideb) = ihigt(imil)
          ihigt(imil) = iwrk
        End If
        If (xdont(ihigt(imil)) < xdont(ihigt(ifin))) Then
          iwrk = ihigt(ifin)
          ihigt(ifin) = ihigt(imil)
          ihigt(imil) = iwrk
          If (xdont(ihigt(imil)) > xdont(ihigt(ideb))) Then
            iwrk = ihigt(ideb)
            ihigt(ideb) = ihigt(imil)
            ihigt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        ! ---
        xpiv = xdont(ihigt(1)) + int(real(nord, sp) / real(jhig + nord, sp), i4) * &
                (xdont(ihigt(ifin)) - xdont(ihigt(1)))
        If (jdeb > 0) Then
          If (xpiv <= xpiv0) &
                  xpiv = xpiv0 + int(real(2 * nord - jdeb, sp) / real(jhig + nord, sp), i4) * &
                          (xdont(ihigt(ifin)) - xpiv0)
        Else
          ideb = 1
        End If
        !
        !  One takes values < XPIV to ILOWT
        !  However, we do not process the first values if we have been
        !  through the case when we did not have enough high values
        ! ---
        jlow = 0
        jhig = jdeb
        ! ---
        If (xdont(ihigt(ifin)) < xpiv) Then
          icrs = jdeb
          Do
            icrs = icrs + 1
            If (xdont(ihigt(icrs)) < xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (icrs >= ifin) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
              If (jhig >= nord) Exit
            End If
          End Do
          ! ---
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ihigt(icrs)) >= xpiv) Then
                jhig = jhig + 1
                ihigt(jhig) = ihigt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = ideb, ifin
            If (xdont(ihigt(icrs)) < xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
              If (jhig >= nord) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) >= xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    ! ---
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    irngt(1) = ihigt(1)
    Do icrs = 2, nord
      iwrk = ihigt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk > xdont(irngt(idcr))) Then
          irngt(idcr + 1) = irngt(idcr)
        Else
          Exit
        End If
      End Do
      irngt(idcr + 1) = iwrk
    End Do
    Return
    !
    !
  End Subroutine i_rapknr
 
  Subroutine d_refpar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm. It uses
    !  a temporary array, where it stores the partially ranked indices
    !  of the values. It iterates until it can bring the number of
    !  values lower than the pivot to exactly NORD, and then uses an
    !  insertion sort to rank this set, since it is supposedly small.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    real(kind = dp) :: xpiv, xwrk
    ! __________________________________________________________
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: IWRKT
    Integer(kind = i4) :: NDON, ICRS, IDEB, IDCR, IFIN, IMIL, IWRK
    !
    ndon = SIZE (xdont)
    !
    Do icrs = 1, ndon
      iwrkt(icrs) = icrs
    End Do
    ideb = 1
    ifin = ndon
    Do
      If (ideb >= ifin) Exit
      imil = (ideb + ifin) / 2
      !
      !  One chooses a pivot, median of 1st, last, and middle values
      !
      If (xdont(iwrkt(imil)) < xdont(iwrkt(ideb))) Then
        iwrk = iwrkt(ideb)
        iwrkt(ideb) = iwrkt(imil)
        iwrkt(imil) = iwrk
      End If
      If (xdont(iwrkt(imil)) > xdont(iwrkt(ifin))) Then
        iwrk = iwrkt(ifin)
        iwrkt(ifin) = iwrkt(imil)
        iwrkt(imil) = iwrk
        If (xdont(iwrkt(imil)) < xdont(iwrkt(ideb))) Then
          iwrk = iwrkt(ideb)
          iwrkt(ideb) = iwrkt(imil)
          iwrkt(imil) = iwrk
        End If
      End If
      If ((ifin - ideb) < 3) Exit
      xpiv = xdont(iwrkt(imil))
      !
      !  One exchanges values to put those > pivot in the end and
      !  those <= pivot at the beginning
      !
      icrs = ideb
      idcr = ifin
      ech2 : Do
        Do
          icrs = icrs + 1
          If (icrs >= idcr) Then
            !
            !  the first  >  pivot is IWRKT(IDCR)
            !  the last   <= pivot is IWRKT(ICRS-1)
            !  Note: If one arrives here on the first iteration, then
            !        the pivot is the maximum of the set, the last value is equal
            !        to it, and one can reduce by one the size of the set to process,
            !        as if XDONT (IWRKT(IFIN)) > XPIV
            !
            Exit ech2
            !
          End If
          If (xdont(iwrkt(icrs)) > xpiv) Exit
        End Do
        Do
          If (xdont(iwrkt(idcr)) <= xpiv) Exit
          idcr = idcr - 1
          If (icrs >= idcr) Then
            !
            !  The last value < pivot is always IWRKT(ICRS-1)
            !
            Exit ech2
          End If
        End Do
        !
        iwrk = iwrkt(idcr)
        iwrkt(idcr) = iwrkt(icrs)
        iwrkt(icrs) = iwrk
      End Do ech2
      !
      !  One restricts further processing to find the fractile value
      !
      If (icrs <= nord) ideb = icrs
      If (icrs > nord) ifin = icrs - 1
    End Do
    !
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    Do icrs = 2, nord
      iwrk = iwrkt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk <= xdont(iwrkt(idcr))) Then
          iwrkt(idcr + 1) = iwrkt(idcr)
        Else
          Exit
        End If
      End Do
      iwrkt(idcr + 1) = iwrk
    End Do
    irngt(1 : nord) = iwrkt(1 : nord)
    Return
    !
  End Subroutine d_refpar
 
  Subroutine r_refpar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm. It uses
    !  a temporary array, where it stores the partially ranked indices
    !  of the values. It iterates until it can bring the number of
    !  values lower than the pivot to exactly NORD, and then uses an
    !  insertion sort to rank this set, since it is supposedly small.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Real(kind = sp) :: xpiv, xwrk
    ! __________________________________________________________
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: IWRKT
    Integer(kind = i4) :: NDON, ICRS, IDEB, IDCR, IFIN, IMIL, IWRK
    !
    ndon = SIZE (xdont)
    !
    Do icrs = 1, ndon
      iwrkt(icrs) = icrs
    End Do
    ideb = 1
    ifin = ndon
    Do
      If (ideb >= ifin) Exit
      imil = (ideb + ifin) / 2
      !
      !  One chooses a pivot, median of 1st, last, and middle values
      !
      If (xdont(iwrkt(imil)) < xdont(iwrkt(ideb))) Then
        iwrk = iwrkt(ideb)
        iwrkt(ideb) = iwrkt(imil)
        iwrkt(imil) = iwrk
      End If
      If (xdont(iwrkt(imil)) > xdont(iwrkt(ifin))) Then
        iwrk = iwrkt(ifin)
        iwrkt(ifin) = iwrkt(imil)
        iwrkt(imil) = iwrk
        If (xdont(iwrkt(imil)) < xdont(iwrkt(ideb))) Then
          iwrk = iwrkt(ideb)
          iwrkt(ideb) = iwrkt(imil)
          iwrkt(imil) = iwrk
        End If
      End If
      If ((ifin - ideb) < 3) Exit
      xpiv = xdont(iwrkt(imil))
      !
      !  One exchanges values to put those > pivot in the end and
      !  those <= pivot at the beginning
      !
      icrs = ideb
      idcr = ifin
      ech2 : Do
        Do
          icrs = icrs + 1
          If (icrs >= idcr) Then
            !
            !  the first  >  pivot is IWRKT(IDCR)
            !  the last   <= pivot is IWRKT(ICRS-1)
            !  Note: If one arrives here on the first iteration, then
            !        the pivot is the maximum of the set, the last value is equal
            !        to it, and one can reduce by one the size of the set to process,
            !        as if XDONT (IWRKT(IFIN)) > XPIV
            !
            Exit ech2
            !
          End If
          If (xdont(iwrkt(icrs)) > xpiv) Exit
        End Do
        Do
          If (xdont(iwrkt(idcr)) <= xpiv) Exit
          idcr = idcr - 1
          If (icrs >= idcr) Then
            !
            !  The last value < pivot is always IWRKT(ICRS-1)
            !
            Exit ech2
          End If
        End Do
        !
        iwrk = iwrkt(idcr)
        iwrkt(idcr) = iwrkt(icrs)
        iwrkt(icrs) = iwrk
      End Do ech2
      !
      !  One restricts further processing to find the fractile value
      !
      If (icrs <= nord) ideb = icrs
      If (icrs > nord) ifin = icrs - 1
    End Do
    !
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    Do icrs = 2, nord
      iwrk = iwrkt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk <= xdont(iwrkt(idcr))) Then
          iwrkt(idcr + 1) = iwrkt(idcr)
        Else
          Exit
        End If
      End Do
      iwrkt(idcr + 1) = iwrk
    End Do
    irngt(1 : nord) = iwrkt(1 : nord)
    Return
    !
  End Subroutine r_refpar
 
  Subroutine i_refpar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm. It uses
    !  a temporary array, where it stores the partially ranked indices
    !  of the values. It iterates until it can bring the number of
    !  values lower than the pivot to exactly NORD, and then uses an
    !  insertion sort to rank this set, since it is supposedly small.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Integer(kind = i4) :: XPIV, XWRK
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: IWRKT
    Integer(kind = i4) :: NDON, ICRS, IDEB, IDCR, IFIN, IMIL, IWRK
    !
    ndon = SIZE (xdont)
    !
    Do icrs = 1, ndon
      iwrkt(icrs) = icrs
    End Do
    ideb = 1
    ifin = ndon
    Do
      If (ideb >= ifin) Exit
      imil = (ideb + ifin) / 2
      !
      !  One chooses a pivot, median of 1st, last, and middle values
      !
      If (xdont(iwrkt(imil)) < xdont(iwrkt(ideb))) Then
        iwrk = iwrkt(ideb)
        iwrkt(ideb) = iwrkt(imil)
        iwrkt(imil) = iwrk
      End If
      If (xdont(iwrkt(imil)) > xdont(iwrkt(ifin))) Then
        iwrk = iwrkt(ifin)
        iwrkt(ifin) = iwrkt(imil)
        iwrkt(imil) = iwrk
        If (xdont(iwrkt(imil)) < xdont(iwrkt(ideb))) Then
          iwrk = iwrkt(ideb)
          iwrkt(ideb) = iwrkt(imil)
          iwrkt(imil) = iwrk
        End If
      End If
      If ((ifin - ideb) < 3) Exit
      xpiv = xdont(iwrkt(imil))
      !
      !  One exchanges values to put those > pivot in the end and
      !  those <= pivot at the beginning
      !
      icrs = ideb
      idcr = ifin
      ech2 : Do
        Do
          icrs = icrs + 1
          If (icrs >= idcr) Then
            !
            !  the first  >  pivot is IWRKT(IDCR)
            !  the last   <= pivot is IWRKT(ICRS-1)
            !  Note: If one arrives here on the first iteration, then
            !        the pivot is the maximum of the set, the last value is equal
            !        to it, and one can reduce by one the size of the set to process,
            !        as if XDONT (IWRKT(IFIN)) > XPIV
            !
            Exit ech2
            !
          End If
          If (xdont(iwrkt(icrs)) > xpiv) Exit
        End Do
        Do
          If (xdont(iwrkt(idcr)) <= xpiv) Exit
          idcr = idcr - 1
          If (icrs >= idcr) Then
            !
            !  The last value < pivot is always IWRKT(ICRS-1)
            !
            Exit ech2
          End If
        End Do
        !
        iwrk = iwrkt(idcr)
        iwrkt(idcr) = iwrkt(icrs)
        iwrkt(icrs) = iwrk
      End Do ech2
      !
      !  One restricts further processing to find the fractile value
      !
      If (icrs <= nord) ideb = icrs
      If (icrs > nord) ifin = icrs - 1
    End Do
    !
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    Do icrs = 2, nord
      iwrk = iwrkt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk <= xdont(iwrkt(idcr))) Then
          iwrkt(idcr + 1) = iwrkt(idcr)
        Else
          Exit
        End If
      End Do
      iwrkt(idcr + 1) = iwrk
    End Do
    irngt(1 : nord) = iwrkt(1 : nord)
    Return
    !
  End Subroutine i_refpar
 
  Subroutine d_refsor (XDONT)
    !  Sorts XDONT into ascending order - Quicksort
    ! __________________________________________________________
    !  Quicksort chooses a "pivot" in the set, and explores the
    !  array from both ends, looking for a value > pivot with the
    !  increasing index, for a value <= pivot with the decreasing
    !  index, and swapping them when it has found one of each.
    !  The array is then subdivided in 2 ([3]) subsets:
    !  { values <= pivot} {pivot} {values > pivot}
    !  One then call recursively the program to sort each subset.
    !  When the size of the subarray is small enough, one uses an
    !  insertion sort that is faster for very small sets.
    !  Michel Olagnon - Apr. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (InOut) :: xdont
    ! __________________________________________________________
    !
    !
    Call d_subsor (xdont, 1, Size (xdont))
    Call d_inssor (xdont)
    Return
  End Subroutine d_refsor
 
  Recursive Subroutine d_subsor (XDONT, IDEB1, IFIN1)
    !  Sorts XDONT from IDEB1 to IFIN1
    ! __________________________________________________________
    Real(kind = dp), dimension (:), Intent (InOut) :: xdont
    Integer(kind = i4), Intent (In) :: IDEB1, IFIN1
    ! __________________________________________________________
    Integer(kind = i4), Parameter :: NINS = 16 ! Max for insertion sort
    Integer(kind = i4) :: ICRS, IDEB, IDCR, IFIN, IMIL
    Real(kind = dp) :: xpiv, xwrk
    !
    ideb = ideb1
    ifin = ifin1
    !
    !  If we don't have enough values to make it worth while, we leave
    !  them unsorted, and the final insertion sort will take care of them
    !
    If ((ifin - ideb) > nins) Then
      imil = (ideb + ifin) / 2
      !
      !  One chooses a pivot, median of 1st, last, and middle values
      !
      If (xdont(imil) < xdont(ideb)) Then
        xwrk = xdont(ideb)
        xdont(ideb) = xdont(imil)
        xdont(imil) = xwrk
      End If
      If (xdont(imil) > xdont(ifin)) Then
        xwrk = xdont(ifin)
        xdont(ifin) = xdont(imil)
        xdont(imil) = xwrk
        If (xdont(imil) < xdont(ideb)) Then
          xwrk = xdont(ideb)
          xdont(ideb) = xdont(imil)
          xdont(imil) = xwrk
        End If
      End If
      xpiv = xdont(imil)
      !
      !  One exchanges values to put those > pivot in the end and
      !  those <= pivot at the beginning
      !
      icrs = ideb
      idcr = ifin
      ech2 : Do
        Do
          icrs = icrs + 1
          If (icrs >= idcr) Then
            !
            !  the first  >  pivot is IDCR
            !  the last   <= pivot is ICRS-1
            !  Note: If one arrives here on the first iteration, then
            !        the pivot is the maximum of the set, the last value is equal
            !        to it, and one can reduce by one the size of the set to process,
            !        as if XDONT (IFIN) > XPIV
            !
            Exit ech2
            !
          End If
          If (xdont(icrs) > xpiv) Exit
        End Do
        Do
          If (xdont(idcr) <= xpiv) Exit
          idcr = idcr - 1
          If (icrs >= idcr) Then
            !
            !  The last value < pivot is always ICRS-1
            !
            Exit ech2
          End If
        End Do
        !
        xwrk = xdont(idcr)
        xdont(idcr) = xdont(icrs)
        xdont(icrs) = xwrk
      End Do ech2
      !
      !  One now sorts each of the two sub-intervals
      !
      Call d_subsor (xdont, ideb1, icrs - 1)
      Call d_subsor (xdont, idcr, ifin1)
    End If
    Return
  End Subroutine d_subsor
  !
  Subroutine r_refsor (XDONT)
    !  Sorts XDONT into ascending order - Quicksort
    ! __________________________________________________________
    !  Quicksort chooses a "pivot" in the set, and explores the
    !  array from both ends, looking for a value > pivot with the
    !  increasing index, for a value <= pivot with the decreasing
    !  index, and swapping them when it has found one of each.
    !  The array is then subdivided in 2 ([3]) subsets:
    !  { values <= pivot} {pivot} {values > pivot}
    !  One then call recursively the program to sort each subset.
    !  When the size of the subarray is small enough, one uses an
    !  insertion sort that is faster for very small sets.
    !  Michel Olagnon - Apr. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (InOut) :: xdont
    ! __________________________________________________________
    !
    !
    Call r_subsor (xdont, 1, Size (xdont))
    Call r_inssor (xdont)
    Return
  End Subroutine r_refsor
 
  Recursive Subroutine r_subsor (XDONT, IDEB1, IFIN1)
    !  Sorts XDONT from IDEB1 to IFIN1
    ! __________________________________________________________
    Real(kind = sp), dimension (:), Intent (InOut) :: xdont
    Integer(kind = i4), Intent (In) :: IDEB1, IFIN1
    ! __________________________________________________________
    Integer(kind = i4), Parameter :: NINS = 16 ! Max for insertion sort
    Integer(kind = i4) :: ICRS, IDEB, IDCR, IFIN, IMIL
    Real(kind = sp) :: xpiv, xwrk
    !
    ideb = ideb1
    ifin = ifin1
    !
    !  If we don't have enough values to make it worth while, we leave
    !  them unsorted, and the final insertion sort will take care of them
    !
    If ((ifin - ideb) > nins) Then
      imil = (ideb + ifin) / 2
      !
      !  One chooses a pivot, median of 1st, last, and middle values
      !
      If (xdont(imil) < xdont(ideb)) Then
        xwrk = xdont(ideb)
        xdont(ideb) = xdont(imil)
        xdont(imil) = xwrk
      End If
      If (xdont(imil) > xdont(ifin)) Then
        xwrk = xdont(ifin)
        xdont(ifin) = xdont(imil)
        xdont(imil) = xwrk
        If (xdont(imil) < xdont(ideb)) Then
          xwrk = xdont(ideb)
          xdont(ideb) = xdont(imil)
          xdont(imil) = xwrk
        End If
      End If
      xpiv = xdont(imil)
      !
      !  One exchanges values to put those > pivot in the end and
      !  those <= pivot at the beginning
      !
      icrs = ideb
      idcr = ifin
      ech2 : Do
        Do
          icrs = icrs + 1
          If (icrs >= idcr) Then
            !
            !  the first  >  pivot is IDCR
            !  the last   <= pivot is ICRS-1
            !  Note: If one arrives here on the first iteration, then
            !        the pivot is the maximum of the set, the last value is equal
            !        to it, and one can reduce by one the size of the set to process,
            !        as if XDONT (IFIN) > XPIV
            !
            Exit ech2
            !
          End If
          If (xdont(icrs) > xpiv) Exit
        End Do
        Do
          If (xdont(idcr) <= xpiv) Exit
          idcr = idcr - 1
          If (icrs >= idcr) Then
            !
            !  The last value < pivot is always ICRS-1
            !
            Exit ech2
          End If
        End Do
        !
        xwrk = xdont(idcr)
        xdont(idcr) = xdont(icrs)
        xdont(icrs) = xwrk
      End Do ech2
      !
      !  One now sorts each of the two sub-intervals
      !
      Call r_subsor (xdont, ideb1, icrs - 1)
      Call r_subsor (xdont, idcr, ifin1)
    End If
    Return
  End Subroutine r_subsor
  !
  Subroutine i_refsor (XDONT)
    !  Sorts XDONT into ascending order - Quicksort
    ! __________________________________________________________
    !  Quicksort chooses a "pivot" in the set, and explores the
    !  array from both ends, looking for a value > pivot with the
    !  increasing index, for a value <= pivot with the decreasing
    !  index, and swapping them when it has found one of each.
    !  The array is then subdivided in 2 ([3]) subsets:
    !  { values <= pivot} {pivot} {values > pivot}
    !  One then call recursively the program to sort each subset.
    !  When the size of the subarray is small enough, one uses an
    !  insertion sort that is faster for very small sets.
    !  Michel Olagnon - Apr. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (InOut) :: XDONT
    ! __________________________________________________________
    !
    !
    Call i_subsor (xdont, 1, Size (xdont))
    Call i_inssor (xdont)
    Return
  End Subroutine i_refsor
 
  Recursive Subroutine i_subsor (XDONT, IDEB1, IFIN1)
    !  Sorts XDONT from IDEB1 to IFIN1
    ! __________________________________________________________
    Integer(kind = i4), dimension (:), Intent (InOut) :: XDONT
    Integer(kind = i4), Intent (In) :: IDEB1, IFIN1
    ! __________________________________________________________
    Integer(kind = i4), Parameter :: NINS = 16 ! Max for insertion sort
    Integer(kind = i4) :: ICRS, IDEB, IDCR, IFIN, IMIL
    Integer(kind = i4) :: XPIV, XWRK
    !
    ideb = ideb1
    ifin = ifin1
    !
    !  If we don't have enough values to make it worth while, we leave
    !  them unsorted, and the final insertion sort will take care of them
    !
    If ((ifin - ideb) > nins) Then
      imil = (ideb + ifin) / 2
      !
      !  One chooses a pivot, median of 1st, last, and middle values
      !
      If (xdont(imil) < xdont(ideb)) Then
        xwrk = xdont(ideb)
        xdont(ideb) = xdont(imil)
        xdont(imil) = xwrk
      End If
      If (xdont(imil) > xdont(ifin)) Then
        xwrk = xdont(ifin)
        xdont(ifin) = xdont(imil)
        xdont(imil) = xwrk
        If (xdont(imil) < xdont(ideb)) Then
          xwrk = xdont(ideb)
          xdont(ideb) = xdont(imil)
          xdont(imil) = xwrk
        End If
      End If
      xpiv = xdont(imil)
      !
      !  One exchanges values to put those > pivot in the end and
      !  those <= pivot at the beginning
      !
      icrs = ideb
      idcr = ifin
      ech2 : Do
        Do
          icrs = icrs + 1
          If (icrs >= idcr) Then
            !
            !  the first  >  pivot is IDCR
            !  the last   <= pivot is ICRS-1
            !  Note: If one arrives here on the first iteration, then
            !        the pivot is the maximum of the set, the last value is equal
            !        to it, and one can reduce by one the size of the set to process,
            !        as if XDONT (IFIN) > XPIV
            !
            Exit ech2
            !
          End If
          If (xdont(icrs) > xpiv) Exit
        End Do
        Do
          If (xdont(idcr) <= xpiv) Exit
          idcr = idcr - 1
          If (icrs >= idcr) Then
            !
            !  The last value < pivot is always ICRS-1
            !
            Exit ech2
          End If
        End Do
        !
        xwrk = xdont(idcr)
        xdont(idcr) = xdont(icrs)
        xdont(icrs) = xwrk
      End Do ech2
      !
      !  One now sorts each of the two sub-intervals
      !
      Call i_subsor (xdont, ideb1, icrs - 1)
      Call i_subsor (xdont, idcr, ifin1)
    End If
    Return
  End Subroutine i_subsor
 
  Subroutine c_refsor (XDONT)
    !  Sorts XDONT into ascending order - Quicksort
    ! __________________________________________________________
    !  Quicksort chooses a "pivot" in the set, and explores the
    !  array from both ends, looking for a value > pivot with the
    !  increasing index, for a value <= pivot with the decreasing
    !  index, and swapping them when it has found one of each.
    !  The array is then subdivided in 2 ([3]) subsets:
    !  { values <= pivot} {pivot} {values > pivot}
    !  One then call recursively the program to sort each subset.
    !  When the size of the subarray is small enough, one uses an
    !  insertion sort that is faster for very small sets.
    !  Michel Olagnon - Apr. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    character(*), Dimension (:), Intent (InOut) :: XDONT
    ! __________________________________________________________
    !
    !
    Call c_subsor (xdont, 1, Size (xdont))
    Call c_inssor (xdont)
    Return
  End Subroutine c_refsor
 
  Recursive Subroutine c_subsor (XDONT, IDEB1, IFIN1)
    !  Sorts XDONT from IDEB1 to IFIN1
    ! __________________________________________________________
    character(*), dimension (:), Intent (InOut) :: XDONT
    Integer(kind = i4), Intent (In) :: IDEB1, IFIN1
    ! __________________________________________________________
    Integer(kind = i4), Parameter :: NINS = 16 ! Max for insertion sort
    Integer(kind = i4) :: ICRS, IDEB, IDCR, IFIN, IMIL
    character(len(XDONT)) :: XPIV, XWRK
    !
    ideb = ideb1
    ifin = ifin1
    !
    !  If we don't have enough values to make it worth while, we leave
    !  them unsorted, and the final insertion sort will take care of them
    !
    If ((ifin - ideb) > nins) Then
      imil = (ideb + ifin) / 2
      !
      !  One chooses a pivot, median of 1st, last, and middle values
      !
      If (xdont(imil) < xdont(ideb)) Then
        xwrk = xdont(ideb)
        xdont(ideb) = xdont(imil)
        xdont(imil) = xwrk
      End If
      If (xdont(imil) > xdont(ifin)) Then
        xwrk = xdont(ifin)
        xdont(ifin) = xdont(imil)
        xdont(imil) = xwrk
        If (xdont(imil) < xdont(ideb)) Then
          xwrk = xdont(ideb)
          xdont(ideb) = xdont(imil)
          xdont(imil) = xwrk
        End If
      End If
      xpiv = xdont(imil)
      !
      !  One exchanges values to put those > pivot in the end and
      !  those <= pivot at the beginning
      !
      icrs = ideb
      idcr = ifin
      ech2 : Do
        Do
          icrs = icrs + 1
          If (icrs >= idcr) Then
            !
            !  the first  >  pivot is IDCR
            !  the last   <= pivot is ICRS-1
            !  Note: If one arrives here on the first iteration, then
            !        the pivot is the maximum of the set, the last value is equal
            !        to it, and one can reduce by one the size of the set to process,
            !        as if XDONT (IFIN) > XPIV
            !
            Exit ech2
            !
          End If
          If (xdont(icrs) > xpiv) Exit
        End Do
        Do
          If (xdont(idcr) <= xpiv) Exit
          idcr = idcr - 1
          If (icrs >= idcr) Then
            !
            !  The last value < pivot is always ICRS-1
            !
            Exit ech2
          End If
        End Do
        !
        xwrk = xdont(idcr)
        xdont(idcr) = xdont(icrs)
        xdont(icrs) = xwrk
      End Do ech2
      !
      !  One now sorts each of the two sub-intervals
      !
      Call c_subsor (xdont, ideb1, icrs - 1)
      Call c_subsor (xdont, idcr, ifin1)
    End If
    Return
  End Subroutine c_subsor
  !
  Subroutine d_rinpar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD = size (IRNGT)
    ! __________________________________________________________
    !  This subroutine uses insertion sort, limiting insertion
    !  to the first NORD values. It does not use any work array
    !  and is faster when NORD is very small (2-5), but worst case
    !  behavior can happen fairly probably (initially inverse sorted)
    !  In many cases, the refined quicksort method is faster.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    real(kind = dp) :: xwrk, xwrk1
    !
    Integer(kind = i4) :: ICRS, IDCR
    !
    irngt(1) = 1
    Do icrs = 2, nord
      xwrk = xdont(icrs)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk >= xdont(irngt(idcr))) Exit
        irngt(idcr + 1) = irngt(idcr)
      End Do
      irngt(idcr + 1) = icrs
    End Do
    !
    xwrk1 = xdont(irngt(nord))
    Do icrs = nord + 1, SIZE (xdont)
      If (xdont(icrs) < xwrk1) Then
        xwrk = xdont(icrs)
        Do idcr = nord - 1, 1, - 1
          If (xwrk >= xdont(irngt(idcr))) Exit
          irngt(idcr + 1) = irngt(idcr)
        End Do
        irngt(idcr + 1) = icrs
        xwrk1 = xdont(irngt(nord))
      End If
    End Do
    !
    !
  End Subroutine d_rinpar
 
  Subroutine r_rinpar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD = size (IRNGT)
    ! __________________________________________________________
    !  This subroutine uses insertion sort, limiting insertion
    !  to the first NORD values. It does not use any work array
    !  and is faster when NORD is very small (2-5), but worst case
    !  behavior can happen fairly probably (initially inverse sorted)
    !  In many cases, the refined quicksort method is faster.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Real(kind = sp) :: xwrk, xwrk1
    !
    Integer(kind = i4) :: ICRS, IDCR
    !
    irngt(1) = 1
    Do icrs = 2, nord
      xwrk = xdont(icrs)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk >= xdont(irngt(idcr))) Exit
        irngt(idcr + 1) = irngt(idcr)
      End Do
      irngt(idcr + 1) = icrs
    End Do
    !
    xwrk1 = xdont(irngt(nord))
    Do icrs = nord + 1, SIZE (xdont)
      If (xdont(icrs) < xwrk1) Then
        xwrk = xdont(icrs)
        Do idcr = nord - 1, 1, - 1
          If (xwrk >= xdont(irngt(idcr))) Exit
          irngt(idcr + 1) = irngt(idcr)
        End Do
        irngt(idcr + 1) = icrs
        xwrk1 = xdont(irngt(nord))
      End If
    End Do
    !
    !
  End Subroutine r_rinpar
 
  Subroutine i_rinpar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD = size (IRNGT)
    ! __________________________________________________________
    !  This subroutine uses insertion sort, limiting insertion
    !  to the first NORD values. It does not use any work array
    !  and is faster when NORD is very small (2-5), but worst case
    !  behavior can happen fairly probably (initially inverse sorted)
    !  In many cases, the refined quicksort method is faster.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Integer(kind = i4) :: XWRK, XWRK1
    !
    Integer(kind = i4) :: ICRS, IDCR
    !
    irngt(1) = 1
    Do icrs = 2, nord
      xwrk = xdont(icrs)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk >= xdont(irngt(idcr))) Exit
        irngt(idcr + 1) = irngt(idcr)
      End Do
      irngt(idcr + 1) = icrs
    End Do
    !
    xwrk1 = xdont(irngt(nord))
    Do icrs = nord + 1, SIZE (xdont)
      If (xdont(icrs) < xwrk1) Then
        xwrk = xdont(icrs)
        Do idcr = nord - 1, 1, - 1
          If (xwrk >= xdont(irngt(idcr))) Exit
          irngt(idcr + 1) = irngt(idcr)
        End Do
        irngt(idcr + 1) = icrs
        xwrk1 = xdont(irngt(nord))
      End If
    End Do
    !
    !
  End Subroutine i_rinpar
 
  Subroutine d_rnkpar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then uses an insertion sort to rank
    !  this set, since it is supposedly small.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    real(kind = dp) :: xpiv, xpiv0, xwrk, xwrk1, xmin, xmax
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
    !
    ndon = SIZE (xdont)
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (nord >= 1) irngt(1) = 1
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      ilowt(1) = 2
      ihigt(1) = 1
    Else
      ilowt(1) = 1
      ihigt(1) = 2
    End If
    !
    If (ndon < 3) Then
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      Return
    End If
    !
    If (xdont(3) <= xdont(ihigt(1))) Then
      ihigt(2) = ihigt(1)
      If (xdont(3) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = 3
      Else
        ihigt(1) = 3
      End If
    Else
      ihigt(2) = 3
    End If
    !
    If (ndon < 4) Then
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      Return
    End If
    !
    If (xdont(ndon) <= xdont(ihigt(1))) Then
      ihigt(3) = ihigt(2)
      ihigt(2) = ihigt(1)
      If (xdont(ndon) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = ndon
      Else
        ihigt(1) = ndon
      End If
    Else
      if (xdont(ndon) < xdont(ihigt(2))) Then
        ihigt(3) = ihigt(2)
        ihigt(2) = ndon
      else
        ihigt(3) = ndon
      end if
    End If
    !
    If (ndon < 5) Then
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      If (nord >= 4) irngt(4) = ihigt(3)
      Return
    End If
    !
    jdeb = 0
    ideb = jdeb + 1
    jlow = ideb
    jhig = 3
    xpiv = xdont(ilowt(ideb)) + real(2 * nord, dp) / real(ndon + nord, dp) * &
            (xdont(ihigt(3)) - xdont(ilowt(ideb)))
    If (xpiv >= xdont(ihigt(1))) Then
      xpiv = xdont(ilowt(ideb)) + real(2 * nord, dp) / real(ndon + nord, dp) * &
              (xdont(ihigt(2)) - xdont(ilowt(ideb)))
      If (xpiv >= xdont(ihigt(1))) &
              xpiv = xdont(ilowt(ideb)) + real(2 * nord, dp) / real(ndon + nord, dp) * &
                      (xdont(ihigt(1)) - xdont(ilowt(ideb)))
    End If
    xpiv0 = xpiv
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the IHIGT array as soon as we have more
    !  than enough values in ILOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            ilowt(jlow) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            ilowt(jlow) = icrs
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      if (jlow == nord) Exit
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to NORD
        !
        If (nord > jlow) Then
          xmin = xdont(ihigt(1))
          ihig = 1
          Do icrs = 2, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              xmin = xdont(ihigt(icrs))
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          ilowt(jlow) = ihigt(ihig)
          ihigt(ihig) = ihigt(jhig)
          jhig = jhig - 1
        Else
          ilow = ilowt(jlow)
          xmax = xdont(ilow)
          Do icrs = 1, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              iwrk = ilowt(icrs)
              xmax = xdont(iwrk)
              ilowt(icrs) = ilow
              ilow = iwrk
            End If
          End Do
          jlow = jlow - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to NORD.
      !
      Select Case (nord - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (*,*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xdont(ihigt(1)) <= xdont(ihigt(2))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
          Else
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(3)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(3) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, nord
            jhig = jhig + 1
            ilowt(icrs) = ihigt(jhig)
          End Do
          jlow = nord
          Exit
          !
        Case (4 :)
          !
          !
          xpiv0 = xpiv
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(ifin)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(ifin) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          !
          jdeb = jlow
          nwrk = nord - jlow
          iwrk1 = ihigt(1)
          jlow = jlow + 1
          ilowt(jlow) = iwrk1
          xpiv = xdont(iwrk1) + real(nwrk, dp) / real(nord + nwrk, dp) * &
                  (xdont(ihigt(ifin)) - xdont(iwrk1))
          !
          !  One takes values <= pivot to ILOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (jlow >= nord) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xdont(ihigt(1))
        ihig = 1
        Do icrs = 2, jhig
          If (xdont(ihigt(icrs)) < xmin) Then
            xmin = xdont(ihigt(icrs))
            ihig = icrs
          End If
        End Do
        !
        jlow = jlow + 1
        ilowt(jlow) = ihigt(ihig)
        Exit
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        irngt(1) = ilowt(1)
        Do icrs = 2, nord
          iwrk = ilowt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk < xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
        End Do
        !
        xwrk1 = xdont(irngt(nord))
        Do icrs = nord + 1, jlow
          If (xdont(ilowt(icrs)) < xwrk1) Then
            xwrk = xdont(ilowt(icrs))
            Do idcr = nord - 1, 1, - 1
              If (xwrk >= xdont(irngt(idcr))) Exit
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ilowt(icrs)
            xwrk1 = xdont(irngt(nord))
          End If
        End Do
        !
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
        ideb = jdeb + 1
        imil = (jlow + ideb) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
          iwrk = ilowt(ideb)
          ilowt(ideb) = ilowt(imil)
          ilowt(imil) = iwrk
        End If
        If (xdont(ilowt(imil)) > xdont(ilowt(ifin))) Then
          iwrk = ilowt(ifin)
          ilowt(ifin) = ilowt(imil)
          ilowt(imil) = iwrk
          If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
            iwrk = ilowt(ideb)
            ilowt(ideb) = ilowt(imil)
            ilowt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xdont(ilowt(1)) + real(nord, dp) / real(jlow + nord, dp) * &
                (xdont(ilowt(ifin)) - xdont(ilowt(1)))
        If (jdeb > 0) Then
          If (xpiv <= xpiv0) &
                  xpiv = xpiv0 + real(2 * nord - jdeb, dp) / real(jlow + nord, dp) * &
                          (xdont(ilowt(ifin)) - xpiv0)
        Else
          ideb = 1
        End If
        !
        !  One takes values > XPIV to IHIGT
        !  However, we do not process the first values if we have been
        !  through the case when we did not have enough low values
        !
        jhig = 0
        jlow = jdeb
        !
        If (xdont(ilowt(ifin)) > xpiv) Then
          icrs = jdeb
          Do
            icrs = icrs + 1
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ilowt(icrs)) <= xpiv) Then
                jlow = jlow + 1
                ilowt(jlow) = ilowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = ideb, ifin
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    irngt(1) = ilowt(1)
    Do icrs = 2, nord
      iwrk = ilowt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk < xdont(irngt(idcr))) Then
          irngt(idcr + 1) = irngt(idcr)
        Else
          Exit
        End If
      End Do
      irngt(idcr + 1) = iwrk
    End Do
    Return
    !
    !
  End Subroutine d_rnkpar
 
  Subroutine r_rnkpar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then uses an insertion sort to rank
    !  this set, since it is supposedly small.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Real(kind = sp) :: xpiv, xpiv0, xwrk, xwrk1, xmin, xmax
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
    !
    ndon = SIZE (xdont)
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (nord >= 1) irngt(1) = 1
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      ilowt(1) = 2
      ihigt(1) = 1
    Else
      ilowt(1) = 1
      ihigt(1) = 2
    End If
    !
    If (ndon < 3) Then
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      Return
    End If
    !
    If (xdont(3) <= xdont(ihigt(1))) Then
      ihigt(2) = ihigt(1)
      If (xdont(3) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = 3
      Else
        ihigt(1) = 3
      End If
    Else
      ihigt(2) = 3
    End If
    !
    If (ndon < 4) Then
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      Return
    End If
    !
    If (xdont(ndon) <= xdont(ihigt(1))) Then
      ihigt(3) = ihigt(2)
      ihigt(2) = ihigt(1)
      If (xdont(ndon) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = ndon
      Else
        ihigt(1) = ndon
      End If
    Else
      if (xdont(ndon) < xdont(ihigt(2))) Then
        ihigt(3) = ihigt(2)
        ihigt(2) = ndon
      else
        ihigt(3) = ndon
      end if
    End If
    !
    If (ndon < 5) Then
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      If (nord >= 4) irngt(4) = ihigt(3)
      Return
    End If
    !
    jdeb = 0
    ideb = jdeb + 1
    jlow = ideb
    jhig = 3
    xpiv = xdont(ilowt(ideb)) + real(2 * nord, sp) / real(ndon + nord, sp) * &
            (xdont(ihigt(3)) - xdont(ilowt(ideb)))
    If (xpiv >= xdont(ihigt(1))) Then
      xpiv = xdont(ilowt(ideb)) + real(2 * nord, sp) / real(ndon + nord, sp) * &
              (xdont(ihigt(2)) - xdont(ilowt(ideb)))
      If (xpiv >= xdont(ihigt(1))) &
              xpiv = xdont(ilowt(ideb)) + real(2 * nord, sp) / real(ndon + nord, sp) * &
                      (xdont(ihigt(1)) - xdont(ilowt(ideb)))
    End If
    xpiv0 = xpiv
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the IHIGT array as soon as we have more
    !  than enough values in ILOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            ilowt(jlow) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            ilowt(jlow) = icrs
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      if (jlow == nord) Exit
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to NORD
        !
        If (nord > jlow) Then
          xmin = xdont(ihigt(1))
          ihig = 1
          Do icrs = 2, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              xmin = xdont(ihigt(icrs))
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          ilowt(jlow) = ihigt(ihig)
          ihigt(ihig) = ihigt(jhig)
          jhig = jhig - 1
        Else
          ilow = ilowt(jlow)
          xmax = xdont(ilow)
          Do icrs = 1, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              iwrk = ilowt(icrs)
              xmax = xdont(iwrk)
              ilowt(icrs) = ilow
              ilow = iwrk
            End If
          End Do
          jlow = jlow - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to NORD.
      !
      Select Case (nord - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (*,*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xdont(ihigt(1)) <= xdont(ihigt(2))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
          Else
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(3)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(3) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, nord
            jhig = jhig + 1
            ilowt(icrs) = ihigt(jhig)
          End Do
          jlow = nord
          Exit
          !
        Case (4 :)
          !
          !
          xpiv0 = xpiv
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(ifin)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(ifin) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          !
          jdeb = jlow
          nwrk = nord - jlow
          iwrk1 = ihigt(1)
          jlow = jlow + 1
          ilowt(jlow) = iwrk1
          xpiv = xdont(iwrk1) + real(nwrk, sp) / real(nord + nwrk, sp) * &
                  (xdont(ihigt(ifin)) - xdont(iwrk1))
          !
          !  One takes values <= pivot to ILOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (jlow >= nord) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xdont(ihigt(1))
        ihig = 1
        Do icrs = 2, jhig
          If (xdont(ihigt(icrs)) < xmin) Then
            xmin = xdont(ihigt(icrs))
            ihig = icrs
          End If
        End Do
        !
        jlow = jlow + 1
        ilowt(jlow) = ihigt(ihig)
        Exit
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        irngt(1) = ilowt(1)
        Do icrs = 2, nord
          iwrk = ilowt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk < xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
        End Do
        !
        xwrk1 = xdont(irngt(nord))
        Do icrs = nord + 1, jlow
          If (xdont(ilowt(icrs)) < xwrk1) Then
            xwrk = xdont(ilowt(icrs))
            Do idcr = nord - 1, 1, - 1
              If (xwrk >= xdont(irngt(idcr))) Exit
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ilowt(icrs)
            xwrk1 = xdont(irngt(nord))
          End If
        End Do
        !
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
        ideb = jdeb + 1
        imil = (jlow + ideb) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
          iwrk = ilowt(ideb)
          ilowt(ideb) = ilowt(imil)
          ilowt(imil) = iwrk
        End If
        If (xdont(ilowt(imil)) > xdont(ilowt(ifin))) Then
          iwrk = ilowt(ifin)
          ilowt(ifin) = ilowt(imil)
          ilowt(imil) = iwrk
          If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
            iwrk = ilowt(ideb)
            ilowt(ideb) = ilowt(imil)
            ilowt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xdont(ilowt(1)) + real(nord, sp) / real(jlow + nord, sp) * &
                (xdont(ilowt(ifin)) - xdont(ilowt(1)))
        If (jdeb > 0) Then
          If (xpiv <= xpiv0) &
                  xpiv = xpiv0 + real(2 * nord - jdeb, sp) / real(jlow + nord, sp) * &
                          (xdont(ilowt(ifin)) - xpiv0)
        Else
          ideb = 1
        End If
        !
        !  One takes values > XPIV to IHIGT
        !  However, we do not process the first values if we have been
        !  through the case when we did not have enough low values
        !
        jhig = 0
        jlow = jdeb
        !
        If (xdont(ilowt(ifin)) > xpiv) Then
          icrs = jdeb
          Do
            icrs = icrs + 1
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ilowt(icrs)) <= xpiv) Then
                jlow = jlow + 1
                ilowt(jlow) = ilowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = ideb, ifin
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    irngt(1) = ilowt(1)
    Do icrs = 2, nord
      iwrk = ilowt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk < xdont(irngt(idcr))) Then
          irngt(idcr + 1) = irngt(idcr)
        Else
          Exit
        End If
      End Do
      irngt(idcr + 1) = iwrk
    End Do
    Return
    !
    !
  End Subroutine r_rnkpar
 
  Subroutine i_rnkpar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then uses an insertion sort to rank
    !  this set, since it is supposedly small.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Integer(kind = i4) :: XPIV, XPIV0, XWRK, XWRK1, XMIN, XMAX
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
    !
    ndon = SIZE (xdont)
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (nord >= 1) irngt(1) = 1
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      ilowt(1) = 2
      ihigt(1) = 1
    Else
      ilowt(1) = 1
      ihigt(1) = 2
    End If
    !
    If (ndon < 3) Then
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      Return
    End If
    !
    If (xdont(3) <= xdont(ihigt(1))) Then
      ihigt(2) = ihigt(1)
      If (xdont(3) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = 3
      Else
        ihigt(1) = 3
      End If
    Else
      ihigt(2) = 3
    End If
    !
    If (ndon < 4) Then
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      Return
    End If
    !
    If (xdont(ndon) <= xdont(ihigt(1))) Then
      ihigt(3) = ihigt(2)
      ihigt(2) = ihigt(1)
      If (xdont(ndon) < xdont(ilowt(1))) Then
        ihigt(1) = ilowt(1)
        ilowt(1) = ndon
      Else
        ihigt(1) = ndon
      End If
    Else
      if (xdont(ndon) < xdont(ihigt(2))) Then
        ihigt(3) = ihigt(2)
        ihigt(2) = ndon
      else
        ihigt(3) = ndon
      end if
    End If
    !
    If (ndon < 5) Then
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      If (nord >= 4) irngt(4) = ihigt(3)
      Return
    End If
    !
    jdeb = 0
    ideb = jdeb + 1
    jlow = ideb
    jhig = 3
    xpiv = xdont(ilowt(ideb)) + int(real(2 * nord, sp) / real(ndon + nord, sp), i4) * &
            (xdont(ihigt(3)) - xdont(ilowt(ideb)))
    If (xpiv >= xdont(ihigt(1))) Then
      xpiv = xdont(ilowt(ideb)) + int(real(2 * nord, sp) / real(ndon + nord, sp), i4) * &
              (xdont(ihigt(2)) - xdont(ilowt(ideb)))
      If (xpiv >= xdont(ihigt(1))) &
              xpiv = xdont(ilowt(ideb)) + int(real(2 * nord, sp) / real(ndon + nord, sp), i4) * &
                      (xdont(ihigt(1)) - xdont(ilowt(ideb)))
    End If
    xpiv0 = xpiv
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the IHIGT array as soon as we have more
    !  than enough values in ILOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            ilowt(jlow) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            ilowt(jlow) = icrs
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      if (jlow == nord) Exit
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to NORD
        !
        If (nord > jlow) Then
          xmin = xdont(ihigt(1))
          ihig = 1
          Do icrs = 2, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              xmin = xdont(ihigt(icrs))
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          ilowt(jlow) = ihigt(ihig)
          ihigt(ihig) = ihigt(jhig)
          jhig = jhig - 1
        Else
          ilow = ilowt(jlow)
          xmax = xdont(ilow)
          Do icrs = 1, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              iwrk = ilowt(icrs)
              xmax = xdont(iwrk)
              ilowt(icrs) = ilow
              ilow = iwrk
            End If
          End Do
          jlow = jlow - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to NORD.
      !
      Select Case (nord - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (*,*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xdont(ihigt(1)) <= xdont(ihigt(2))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
          Else
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(3)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(3) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, nord
            jhig = jhig + 1
            ilowt(icrs) = ihigt(jhig)
          End Do
          jlow = nord
          Exit
          !
        Case (4 :)
          !
          !
          xpiv0 = xpiv
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(ifin)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(ifin) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          !
          jdeb = jlow
          nwrk = nord - jlow
          iwrk1 = ihigt(1)
          jlow = jlow + 1
          ilowt(jlow) = iwrk1
          xpiv = xdont(iwrk1) + int(real(nwrk, sp) / real(nord + nwrk, sp), i4) * &
                  (xdont(ihigt(ifin)) - xdont(iwrk1))
          !
          !  One takes values <= pivot to ILOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (jlow >= nord) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xdont(ihigt(1))
        ihig = 1
        Do icrs = 2, jhig
          If (xdont(ihigt(icrs)) < xmin) Then
            xmin = xdont(ihigt(icrs))
            ihig = icrs
          End If
        End Do
        !
        jlow = jlow + 1
        ilowt(jlow) = ihigt(ihig)
        Exit
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        irngt(1) = ilowt(1)
        Do icrs = 2, nord
          iwrk = ilowt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk < xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
        End Do
        !
        xwrk1 = xdont(irngt(nord))
        Do icrs = nord + 1, jlow
          If (xdont(ilowt(icrs)) < xwrk1) Then
            xwrk = xdont(ilowt(icrs))
            Do idcr = nord - 1, 1, - 1
              If (xwrk >= xdont(irngt(idcr))) Exit
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ilowt(icrs)
            xwrk1 = xdont(irngt(nord))
          End If
        End Do
        !
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
        ideb = jdeb + 1
        imil = (jlow + ideb) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
          iwrk = ilowt(ideb)
          ilowt(ideb) = ilowt(imil)
          ilowt(imil) = iwrk
        End If
        If (xdont(ilowt(imil)) > xdont(ilowt(ifin))) Then
          iwrk = ilowt(ifin)
          ilowt(ifin) = ilowt(imil)
          ilowt(imil) = iwrk
          If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
            iwrk = ilowt(ideb)
            ilowt(ideb) = ilowt(imil)
            ilowt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xdont(ilowt(1)) + int(real(nord, sp) / real(jlow + nord, sp), i4) * &
                (xdont(ilowt(ifin)) - xdont(ilowt(1)))
        If (jdeb > 0) Then
          If (xpiv <= xpiv0) &
                  xpiv = xpiv0 + int(real(2 * nord - jdeb, sp) / real(jlow + nord, sp), i4) * &
                          (xdont(ilowt(ifin)) - xpiv0)
        Else
          ideb = 1
        End If
        !
        !  One takes values > XPIV to IHIGT
        !  However, we do not process the first values if we have been
        !  through the case when we did not have enough low values
        !
        jhig = 0
        jlow = jdeb
        !
        If (xdont(ilowt(ifin)) > xpiv) Then
          icrs = jdeb
          Do
            icrs = icrs + 1
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ilowt(icrs)) <= xpiv) Then
                jlow = jlow + 1
                ilowt(jlow) = ilowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = ideb, ifin
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            Else
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    irngt(1) = ilowt(1)
    Do icrs = 2, nord
      iwrk = ilowt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk < xdont(irngt(idcr))) Then
          irngt(idcr + 1) = irngt(idcr)
        Else
          Exit
        End If
      End Do
      irngt(idcr + 1) = iwrk
    End Do
    Return
    !
    !
  End Subroutine i_rnkpar
 
  Subroutine d_uniinv (XDONT, IGOEST)
    ! __________________________________________________________
    !   UNIINV = Merge-sort inverse ranking of an array, with removal of
    !   duplicate entries.
    !   The routine is similar to pure merge-sort ranking, but on
    !   the last pass, it sets indices in IGOEST to the rank
    !   of the value in the ordered set with duplicates removed.
    !   For performance reasons, the first 2 passes are taken
    !   out of the standard loop, and use dedicated coding.
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IGOEST
    ! __________________________________________________________
    real(kind = dp) :: xtst, xdona, xdonb
    !
    ! __________________________________________________________
    Integer(kind = i4), Dimension (SIZE(IGOEST)) :: JWRKT, IRNGT
    Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2, NUNI
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    !
    nval = min(SIZE(xdont), SIZE(igoest))
    !
    Select Case (nval)
    Case (: 0)
      Return
    Case (1)
      igoest(1) = 1
      Return
    Case Default
 
    End Select
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xdont(iind - 1) < xdont(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    lmtna = 2
    lmtnc = 4
    !
    !  First iteration. The length of the ordered subsets goes from 2 to 4
    !
    Do
      If (nval <= 4) Exit
      !
      !   Loop on merges of A and B into C
      !
      Do iwrkd = 0, nval - 1, 4
        If ((iwrkd + 4) > nval) Then
          If ((iwrkd + 2) >= nval) Exit
          !
          !   1 2 3
          !
          If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) Exit
          !
          !   1 3 2
          !
          If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
            irng2 = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irng2
            !
            !   3 1 2
            !
          Else
            irng1 = irngt(iwrkd + 1)
            irngt(iwrkd + 1) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irng1
          End If
          If (.true.) Exit   ! Exit ! JM
        End If
        !
        !   1 2 3 4
        !
        If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) cycle
        !
        !   1 3 x x
        !
        If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 2) = irngt(iwrkd + 3)
          If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
            !   1 3 2 4
            irngt(iwrkd + 3) = irng2
          Else
            !   1 3 4 2
            irngt(iwrkd + 3) = irngt(iwrkd + 4)
            irngt(iwrkd + 4) = irng2
          End If
          !
          !   3 x x x
          !
        Else
          irng1 = irngt(iwrkd + 1)
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 1) = irngt(iwrkd + 3)
          If (xdont(irng1) <= xdont(irngt(iwrkd + 4))) Then
            irngt(iwrkd + 2) = irng1
            If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
              !   3 1 2 4
              irngt(iwrkd + 3) = irng2
            Else
              !   3 1 4 2
              irngt(iwrkd + 3) = irngt(iwrkd + 4)
              irngt(iwrkd + 4) = irng2
            End If
          Else
            !   3 4 1 2
            irngt(iwrkd + 2) = irngt(iwrkd + 4)
            irngt(iwrkd + 3) = irng1
            irngt(iwrkd + 4) = irng2
          End If
        End If
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 4
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    !  Iteration loop. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (2 * lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      !
      !   Loop on merges of A and B into C
      !
      Do
        iwrk = iwrkf
        iwrkd = iwrkf + 1
        jinda = iwrkf + lmtna
        iwrkf = iwrkf + lmtnc
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iinda = 1
        iindb = jinda + 1
        !
        !  One steps in the C subset, that we create in the final rank array
        !
        !  Make a copy of the rank array for the iteration
        !
        jwrkt(1 : lmtna) = irngt(iwrkd : jinda)
        xdona = xdont(jwrkt(iinda))
        xdonb = xdont(irngt(iindb))
        !
        Do
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (xdona > xdonb) Then
            irngt(iwrk) = irngt(iindb)
            iindb = iindb + 1
            If (iindb > iwrkf) Then
              !  Only A still with unprocessed values
              irngt(iwrk + 1 : iwrkf) = jwrkt(iinda : lmtna)
              Exit
            End If
            xdonb = xdont(irngt(iindb))
          Else
            irngt(iwrk) = jwrkt(iinda)
            iinda = iinda + 1
            If (iinda > lmtna) exit! Only B still with unprocessed values
            xdona = xdont(jwrkt(iinda))
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    !   Last merge of A and B into C, with removal of duplicates.
    !
    iinda = 1
    iindb = lmtna + 1
    nuni = 0
    !
    !  One steps in the C subset, that we create in the final rank array
    !
    jwrkt(1 : lmtna) = irngt(1 : lmtna)
    If (iindb <= nval) Then
      xtst = nearless(min(xdont(jwrkt(1)), xdont(irngt(iindb))))
    Else
      xtst = nearless(xdont(jwrkt(1)))
    end if
    Do iwrk = 1, nval
      !
      !  We still have unprocessed values in both A and B
      !
      If (iinda <= lmtna) Then
        If (iindb <= nval) Then
          If (xdont(jwrkt(iinda)) > xdont(irngt(iindb))) Then
            irng = irngt(iindb)
            iindb = iindb + 1
          Else
            irng = jwrkt(iinda)
            iinda = iinda + 1
          End If
        Else
          !
          !  Only A still with unprocessed values
          !
          irng = jwrkt(iinda)
          iinda = iinda + 1
        End If
      Else
        !
        !  Only B still with unprocessed values
        !
        irng = irngt(iwrk)
      End If
      If (xdont(irng) > xtst) Then
        xtst = xdont(irng)
        nuni = nuni + 1
      End If
      igoest(irng) = nuni
      !
    End Do
    !
    Return
    !
  End Subroutine d_uniinv
 
  Subroutine r_uniinv (XDONT, IGOEST)
    ! __________________________________________________________
    !   UNIINV = Merge-sort inverse ranking of an array, with removal of
    !   duplicate entries.
    !   The routine is similar to pure merge-sort ranking, but on
    !   the last pass, it sets indices in IGOEST to the rank
    !   of the value in the ordered set with duplicates removed.
    !   For performance reasons, the first 2 passes are taken
    !   out of the standard loop, and use dedicated coding.
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IGOEST
    ! __________________________________________________________
    Real(kind = sp) :: xtst, xdona, xdonb
    !
    ! __________________________________________________________
    Integer(kind = i4), Dimension (SIZE(IGOEST)) :: JWRKT, IRNGT
    Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2, NUNI
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    !
    nval = min(SIZE(xdont), SIZE(igoest))
    !
    Select Case (nval)
    Case (: 0)
      Return
    Case (1)
      igoest(1) = 1
      Return
    Case Default
 
    End Select
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xdont(iind - 1) < xdont(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    lmtna = 2
    lmtnc = 4
    !
    !  First iteration. The length of the ordered subsets goes from 2 to 4
    !
    Do
      If (nval <= 4) Exit
      !
      !   Loop on merges of A and B into C
      !
      Do iwrkd = 0, nval - 1, 4
        If ((iwrkd + 4) > nval) Then
          If ((iwrkd + 2) >= nval) Exit
          !
          !   1 2 3
          !
          If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) Exit
          !
          !   1 3 2
          !
          If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
            irng2 = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irng2
            !
            !   3 1 2
            !
          Else
            irng1 = irngt(iwrkd + 1)
            irngt(iwrkd + 1) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irng1
          End If
          If (.true.) Exit   ! Exit ! JM
        End If
        !
        !   1 2 3 4
        !
        If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) cycle
        !
        !   1 3 x x
        !
        If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 2) = irngt(iwrkd + 3)
          If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
            !   1 3 2 4
            irngt(iwrkd + 3) = irng2
          Else
            !   1 3 4 2
            irngt(iwrkd + 3) = irngt(iwrkd + 4)
            irngt(iwrkd + 4) = irng2
          End If
          !
          !   3 x x x
          !
        Else
          irng1 = irngt(iwrkd + 1)
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 1) = irngt(iwrkd + 3)
          If (xdont(irng1) <= xdont(irngt(iwrkd + 4))) Then
            irngt(iwrkd + 2) = irng1
            If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
              !   3 1 2 4
              irngt(iwrkd + 3) = irng2
            Else
              !   3 1 4 2
              irngt(iwrkd + 3) = irngt(iwrkd + 4)
              irngt(iwrkd + 4) = irng2
            End If
          Else
            !   3 4 1 2
            irngt(iwrkd + 2) = irngt(iwrkd + 4)
            irngt(iwrkd + 3) = irng1
            irngt(iwrkd + 4) = irng2
          End If
        End If
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 4
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    !  Iteration loop. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (2 * lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      !
      !   Loop on merges of A and B into C
      !
      Do
        iwrk = iwrkf
        iwrkd = iwrkf + 1
        jinda = iwrkf + lmtna
        iwrkf = iwrkf + lmtnc
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iinda = 1
        iindb = jinda + 1
        !
        !  One steps in the C subset, that we create in the final rank array
        !
        !  Make a copy of the rank array for the iteration
        !
        jwrkt(1 : lmtna) = irngt(iwrkd : jinda)
        xdona = xdont(jwrkt(iinda))
        xdonb = xdont(irngt(iindb))
        !
        Do
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (xdona > xdonb) Then
            irngt(iwrk) = irngt(iindb)
            iindb = iindb + 1
            If (iindb > iwrkf) Then
              !  Only A still with unprocessed values
              irngt(iwrk + 1 : iwrkf) = jwrkt(iinda : lmtna)
              Exit
            End If
            xdonb = xdont(irngt(iindb))
          Else
            irngt(iwrk) = jwrkt(iinda)
            iinda = iinda + 1
            If (iinda > lmtna) exit! Only B still with unprocessed values
            xdona = xdont(jwrkt(iinda))
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    !   Last merge of A and B into C, with removal of duplicates.
    !
    iinda = 1
    iindb = lmtna + 1
    nuni = 0
    !
    !  One steps in the C subset, that we create in the final rank array
    !
    jwrkt(1 : lmtna) = irngt(1 : lmtna)
    If (iindb <= nval) Then
      xtst = nearless(min(xdont(jwrkt(1)), xdont(irngt(iindb))))
    Else
      xtst = nearless(xdont(jwrkt(1)))
    end if
    Do iwrk = 1, nval
      !
      !  We still have unprocessed values in both A and B
      !
      If (iinda <= lmtna) Then
        If (iindb <= nval) Then
          If (xdont(jwrkt(iinda)) > xdont(irngt(iindb))) Then
            irng = irngt(iindb)
            iindb = iindb + 1
          Else
            irng = jwrkt(iinda)
            iinda = iinda + 1
          End If
        Else
          !
          !  Only A still with unprocessed values
          !
          irng = jwrkt(iinda)
          iinda = iinda + 1
        End If
      Else
        !
        !  Only B still with unprocessed values
        !
        irng = irngt(iwrk)
      End If
      If (xdont(irng) > xtst) Then
        xtst = xdont(irng)
        nuni = nuni + 1
      End If
      igoest(irng) = nuni
      !
    End Do
    !
    Return
    !
  End Subroutine r_uniinv
 
  Subroutine i_uniinv (XDONT, IGOEST)
    ! __________________________________________________________
    !   UNIINV = Merge-sort inverse ranking of an array, with removal of
    !   duplicate entries.
    !   The routine is similar to pure merge-sort ranking, but on
    !   the last pass, it sets indices in IGOEST to the rank
    !   of the value in the ordered set with duplicates removed.
    !   For performance reasons, the first 2 passes are taken
    !   out of the standard loop, and use dedicated coding.
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4), Dimension (:), Intent (Out) :: IGOEST
    ! __________________________________________________________
    Integer(kind = i4) :: XTST, XDONA, XDONB
    !
    ! __________________________________________________________
    Integer(kind = i4), Dimension (SIZE(IGOEST)) :: JWRKT, IRNGT
    Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2, NUNI
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    !
    nval = min(SIZE(xdont), SIZE(igoest))
    !
    Select Case (nval)
    Case (: 0)
      Return
    Case (1)
      igoest(1) = 1
      Return
    Case Default
 
    End Select
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xdont(iind - 1) < xdont(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    lmtna = 2
    lmtnc = 4
    !
    !  First iteration. The length of the ordered subsets goes from 2 to 4
    !
    Do
      If (nval <= 4) Exit
      !
      !   Loop on merges of A and B into C
      !
      Do iwrkd = 0, nval - 1, 4
        If ((iwrkd + 4) > nval) Then
          If ((iwrkd + 2) >= nval) Exit
          !
          !   1 2 3
          !
          If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) Exit
          !
          !   1 3 2
          !
          If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
            irng2 = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irng2
            !
            !   3 1 2
            !
          Else
            irng1 = irngt(iwrkd + 1)
            irngt(iwrkd + 1) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irng1
          End If
          If (.true.) Exit   ! Exit ! JM
        End If
        !
        !   1 2 3 4
        !
        If (xdont(irngt(iwrkd + 2)) <= xdont(irngt(iwrkd + 3))) cycle
        !
        !   1 3 x x
        !
        If (xdont(irngt(iwrkd + 1)) <= xdont(irngt(iwrkd + 3))) Then
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 2) = irngt(iwrkd + 3)
          If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
            !   1 3 2 4
            irngt(iwrkd + 3) = irng2
          Else
            !   1 3 4 2
            irngt(iwrkd + 3) = irngt(iwrkd + 4)
            irngt(iwrkd + 4) = irng2
          End If
          !
          !   3 x x x
          !
        Else
          irng1 = irngt(iwrkd + 1)
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 1) = irngt(iwrkd + 3)
          If (xdont(irng1) <= xdont(irngt(iwrkd + 4))) Then
            irngt(iwrkd + 2) = irng1
            If (xdont(irng2) <= xdont(irngt(iwrkd + 4))) Then
              !   3 1 2 4
              irngt(iwrkd + 3) = irng2
            Else
              !   3 1 4 2
              irngt(iwrkd + 3) = irngt(iwrkd + 4)
              irngt(iwrkd + 4) = irng2
            End If
          Else
            !   3 4 1 2
            irngt(iwrkd + 2) = irngt(iwrkd + 4)
            irngt(iwrkd + 3) = irng1
            irngt(iwrkd + 4) = irng2
          End If
        End If
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 4
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    !  Iteration loop. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (2 * lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      !
      !   Loop on merges of A and B into C
      !
      Do
        iwrk = iwrkf
        iwrkd = iwrkf + 1
        jinda = iwrkf + lmtna
        iwrkf = iwrkf + lmtnc
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iinda = 1
        iindb = jinda + 1
        !
        !  One steps in the C subset, that we create in the final rank array
        !
        !  Make a copy of the rank array for the iteration
        !
        jwrkt(1 : lmtna) = irngt(iwrkd : jinda)
        xdona = xdont(jwrkt(iinda))
        xdonb = xdont(irngt(iindb))
        !
        Do
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (xdona > xdonb) Then
            irngt(iwrk) = irngt(iindb)
            iindb = iindb + 1
            If (iindb > iwrkf) Then
              !  Only A still with unprocessed values
              irngt(iwrk + 1 : iwrkf) = jwrkt(iinda : lmtna)
              Exit
            End If
            xdonb = xdont(irngt(iindb))
          Else
            irngt(iwrk) = jwrkt(iinda)
            iinda = iinda + 1
            If (iinda > lmtna) exit! Only B still with unprocessed values
            xdona = xdont(jwrkt(iinda))
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    !   Last merge of A and B into C, with removal of duplicates.
    !
    iinda = 1
    iindb = lmtna + 1
    nuni = 0
    !
    !  One steps in the C subset, that we create in the final rank array
    !
    jwrkt(1 : lmtna) = irngt(1 : lmtna)
    If (iindb <= nval) Then
      xtst = nearless(min(xdont(jwrkt(1)), xdont(irngt(iindb))))
    Else
      xtst = nearless(xdont(jwrkt(1)))
    end if
    Do iwrk = 1, nval
      !
      !  We still have unprocessed values in both A and B
      !
      If (iinda <= lmtna) Then
        If (iindb <= nval) Then
          If (xdont(jwrkt(iinda)) > xdont(irngt(iindb))) Then
            irng = irngt(iindb)
            iindb = iindb + 1
          Else
            irng = jwrkt(iinda)
            iinda = iinda + 1
          End If
        Else
          !
          !  Only A still with unprocessed values
          !
          irng = jwrkt(iinda)
          iinda = iinda + 1
        End If
      Else
        !
        !  Only B still with unprocessed values
        !
        irng = irngt(iwrk)
      End If
      If (xdont(irng) > xtst) Then
        xtst = xdont(irng)
        nuni = nuni + 1
      End If
      igoest(irng) = nuni
      !
    End Do
    !
    Return
    !
  End Subroutine i_uniinv
 
  Function d_nearless (XVAL) result (D_nl)
    !  Nearest value less than given value
    ! __________________________________________________________
    real(kind = dp), Intent (In) :: xval
    real(kind = dp) :: d_nl
    ! __________________________________________________________
    d_nl = nearest(xval, -1.0_dp)
    return
    !
  End Function d_nearless
 
  Function r_nearless (XVAL) result (R_nl)
    !  Nearest value less than given value
    ! __________________________________________________________
    Real(kind = sp), Intent (In) :: xval
    Real(kind = sp) :: r_nl
    ! __________________________________________________________
    r_nl = nearest(xval, -1.0)
    return
    !
  End Function r_nearless
 
  Function i_nearless (XVAL) result (I_nl)
    !  Nearest value less than given value
    ! __________________________________________________________
    Integer(kind = i4), Intent (In) :: XVAL
    Integer(kind = i4) :: I_nl
    ! __________________________________________________________
    i_nl = xval - 1
    return
    !
  End Function i_nearless
 
 
  Subroutine d_unipar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD at most,
    !  removing duplicate entries
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  quickly as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then uses an insertion sort to rank
    !  this set, since it is supposedly small. At all times, the
    !  NORD first values in ILOWT correspond to distinct values
    !  of the input array.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (InOut) :: NORD
    ! __________________________________________________________
    real(kind = dp) :: xpiv, xwrk, xwrk1, xmin, xmax, xpiv0
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
    !
    ndon = SIZE (xdont)
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (nord >= 1) Then
        nord = 1
        irngt(1) = 1
      End If
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    Do icrs = 2, ndon
      If (eq(xdont(icrs), xdont(1))) Then
        cycle
      Else If (xdont(icrs) < xdont(1)) Then
        ilowt(1) = icrs
        ihigt(1) = 1
      Else
        ilowt(1) = 1
        ihigt(1) = icrs
      End If
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    If (ndon <= icrs) Then
      nord = min(nord, 2)
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      Return
    End If
    !
    icrs = icrs + 1
    jhig = 1
    If (xdont(icrs) < xdont(ihigt(1))) Then
      If (xdont(icrs) < xdont(ilowt(1))) Then
        jhig = jhig + 1
        ihigt(jhig) = ihigt(1)
        ihigt(1) = ilowt(1)
        ilowt(1) = icrs
      Else If (xdont(icrs) > xdont(ilowt(1))) Then
        jhig = jhig + 1
        ihigt(jhig) = ihigt(1)
        ihigt(1) = icrs
      End If
    ElseIf (xdont(icrs) > xdont(ihigt(1))) Then
      jhig = jhig + 1
      ihigt(jhig) = icrs
    End If
    !
    If (ndon <= icrs) Then
      nord = min(nord, jhig + 1)
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      Return
    End If
    !
    If (xdont(ndon) < xdont(ihigt(1))) Then
      If (xdont(ndon) < xdont(ilowt(1))) Then
        Do idcr = jhig, 1, -1
          ihigt(idcr + 1) = ihigt(idcr)
        End Do
        ihigt(1) = ilowt(1)
        ilowt(1) = ndon
        jhig = jhig + 1
      ElseIf (xdont(ndon) > xdont(ilowt(1))) Then
        Do idcr = jhig, 1, -1
          ihigt(idcr + 1) = ihigt(idcr)
        End Do
        ihigt(1) = ndon
        jhig = jhig + 1
      End If
    ElseIf (xdont(ndon) > xdont(ihigt(1))) Then
      jhig = jhig + 1
      ihigt(jhig) = ndon
    End If
    !
    If (ndon <= icrs + 1) Then
      nord = min(nord, jhig + 1)
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      If (nord >= 4) irngt(4) = ihigt(3)
      Return
    End If
    !
    jdeb = 0
    ideb = jdeb + 1
    jlow = ideb
    xpiv = xdont(ilowt(ideb)) + real(2 * nord, dp) / real(ndon + nord, dp) * &
            (xdont(ihigt(3)) - xdont(ilowt(ideb)))
    If (xpiv >= xdont(ihigt(1))) Then
      xpiv = xdont(ilowt(ideb)) + real(2 * nord, dp) / real(ndon + nord, dp) * &
              (xdont(ihigt(2)) - xdont(ilowt(ideb)))
      If (xpiv >= xdont(ihigt(1))) &
              xpiv = xdont(ilowt(ideb)) + real(2 * nord, dp) / real(ndon + nord, dp) * &
                      (xdont(ihigt(1)) - xdont(ilowt(ideb)))
    End If
    xpiv0 = xpiv
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the IHIGT array as soon as we have more
    !  than enough values in ILOWT, i.e. one more than
    !  strictly necessary so as to be able to come out of the
    !  case where JLOWT would be NORD distinct values followed
    !  by values that are exclusively duplicates of these.
    !
    !
    If (xdont(ndon) > xpiv) Then
      lowloop1 : Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          Do ilow = 1, jlow
            If (eq(xdont(icrs), xdont(ilowt(ilow)))) cycle lowloop1
          End Do
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do lowloop1
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            ilowt(jlow) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      lowloop2 : Do icrs = icrs + 1, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          Do ilow = 1, jlow
            If (eq(xdont(icrs), xdont(ilowt(ilow)))) cycle lowloop2
          End Do
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do lowloop2
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            ilowt(jlow) = icrs
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      if (jlow == nord) Exit
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to NORD
        !
        If (nord > jlow) Then
          xmin = xdont(ihigt(1))
          ihig = 1
          Do icrs = 2, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              xmin = xdont(ihigt(icrs))
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          ilowt(jlow) = ihigt(ihig)
          ihig = 0
          Do icrs = 1, jhig
            If (ne(xdont(ihigt(icrs)), xmin)) then
              ihig = ihig + 1
              ihigt(ihig) = ihigt(icrs)
            End If
          End Do
          jhig = ihig
        Else
          ilow = ilowt(jlow)
          xmax = xdont(ilow)
          Do icrs = 1, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              iwrk = ilowt(icrs)
              xmax = xdont(iwrk)
              ilowt(icrs) = ilow
              ilow = iwrk
            End If
          End Do
          jlow = jlow - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to NORD. In order to make better pivot choices, we
      !   decrease NORD if we already know that we don't have that
      !   many distinct values as a whole.
      !
      IF (jlow + jhig < nord) nord = jlow + jhig
      Select Case (nord - jlow)
        ! ______________________________
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        Select Case (jhig)
          !
          !   Not enough values in high part either (too many duplicates)
          !
        Case (0)
          nord = jlow
          !
        Case (1)
          jlow = jlow + 1
          ilowt(jlow) = ihigt(1)
          nord = jlow
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (le(xdont(ihigt(1)), xdont(ihigt(2)))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
          ElseIf (eq(xdont(ihigt(1)), xdont(ihigt(2)))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            nord = jlow
          Else
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(3)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(3) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          jhig = 1
          jlow = jlow + 1
          ilowt(jlow) = ihigt(1)
          jhig = jhig + 1
          IF (ne(xdont(ihigt(jhig)), xdont(ilowt(jlow)))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(jhig)
          End If
          jhig = jhig + 1
          IF (ne(xdont(ihigt(jhig)), xdont(ilowt(jlow)))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(jhig)
          End If
          nord = min(jlow, nord)
          Exit
          !
        Case (4 :)
          !
          !
          xpiv0 = xpiv
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(ifin)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(ifin) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          !
          jdeb = jlow
          nwrk = nord - jlow
          iwrk1 = ihigt(1)
          xpiv = xdont(iwrk1) + real(nwrk, dp) / real(nord + nwrk, dp) * &
                  (xdont(ihigt(ifin)) - xdont(iwrk1))
          !
          !  One takes values <= pivot to ILOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          lowloop3 : Do icrs = 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              Do ilow = 1, jlow
                If (eq(xdont(ihigt(icrs)), xdont(ilowt(ilow)))) &
                        cycle lowloop3
              End Do
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (jlow > nord) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do lowloop3
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            End If
          End Do
        End Select
        !
        ! ______________________________
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xdont(ihigt(1))
        ihig = 1
        Do icrs = 2, jhig
          If (xdont(ihigt(icrs)) < xmin) Then
            xmin = xdont(ihigt(icrs))
            ihig = icrs
          End If
        End Do
        !
        jlow = jlow + 1
        ilowt(jlow) = ihigt(ihig)
        Exit
        !
        ! ______________________________
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        ! ______________________________
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        irngt(1) = ilowt(1)
        Do icrs = 2, nord
          iwrk = ilowt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk < xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
        End Do
        !
        xwrk1 = xdont(irngt(nord))
        insert1 : Do icrs = nord + 1, jlow
          If (xdont(ilowt(icrs)) < xwrk1) Then
            xwrk = xdont(ilowt(icrs))
            Do ilow = 1, nord - 1
              If (xwrk <= xdont(irngt(ilow))) Then
                If (eq(xwrk, xdont(irngt(ilow)))) cycle insert1
                Exit
              End If
            End Do
            Do idcr = nord - 1, ilow, - 1
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ilowt(icrs)
            xwrk1 = xdont(irngt(nord))
          End If
        End Do insert1
        !
        Return
        !
        ! ______________________________
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
        ideb = jdeb + 1
        imil = min((jlow + ideb) / 2, nord)
        ifin = min(jlow, nord + 1)
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
          iwrk = ilowt(ideb)
          ilowt(ideb) = ilowt(imil)
          ilowt(imil) = iwrk
        End If
        If (xdont(ilowt(imil)) > xdont(ilowt(ifin))) Then
          iwrk = ilowt(ifin)
          ilowt(ifin) = ilowt(imil)
          ilowt(imil) = iwrk
          If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
            iwrk = ilowt(ideb)
            ilowt(ideb) = ilowt(imil)
            ilowt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xdont(ilowt(ideb)) + real(nord, dp) / real(jlow + nord, dp) * &
                (xdont(ilowt(ifin)) - xdont(ilowt(1)))
        If (jdeb > 0) Then
          If (xpiv <= xpiv0) &
                  xpiv = xpiv0 + real(2 * nord - jdeb, dp) / real(jlow + nord, dp) * &
                          (xdont(ilowt(ifin)) - xpiv0)
        Else
          ideb = 1
        End If
        !
        !  One takes values > XPIV to IHIGT
        !  However, we do not process the first values if we have been
        !  through the case when we did not have enough low values
        !
        jhig = 0
        ifin = jlow
        jlow = jdeb
        !
        If (xdont(ilowt(ifin)) > xpiv) Then
          icrs = jdeb
          lowloop4 : Do
            icrs = icrs + 1
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (icrs >= ifin) Exit
            Else
              xwrk1 = xdont(ilowt(icrs))
              Do ilow = ideb, jlow
                If (eq(xwrk1, xdont(ilowt(ilow)))) &
                        cycle lowloop4
              End Do
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do lowloop4
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ilowt(icrs)) <= xpiv) Then
                jlow = jlow + 1
                ilowt(jlow) = ilowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          lowloop5 : Do icrs = ideb, ifin
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            Else
              xwrk1 = xdont(ilowt(icrs))
              Do ilow = ideb, jlow
                If (eq(xwrk1, xdont(ilowt(ilow)))) &
                        cycle lowloop5
              End Do
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do lowloop5
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      ! ______________________________
      !
    End Do
    !
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    irngt(1) = ilowt(1)
    Do icrs = 2, nord
      iwrk = ilowt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk < xdont(irngt(idcr))) Then
          irngt(idcr + 1) = irngt(idcr)
        Else
          Exit
        End If
      End Do
      irngt(idcr + 1) = iwrk
    End Do
    Return
    !
    !
  End Subroutine d_unipar
 
  Subroutine r_unipar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD at most,
    !  removing duplicate entries
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  quickly as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then uses an insertion sort to rank
    !  this set, since it is supposedly small. At all times, the
    !  NORD first values in ILOWT correspond to distinct values
    !  of the input array.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (InOut) :: NORD
    ! __________________________________________________________
    Real(kind = sp) :: xpiv, xwrk, xwrk1, xmin, xmax, xpiv0
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
    !
    ndon = SIZE (xdont)
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (nord >= 1) Then
        nord = 1
        irngt(1) = 1
      End If
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    Do icrs = 2, ndon
      If (eq(xdont(icrs), xdont(1))) Then
        cycle
      Else If (xdont(icrs) < xdont(1)) Then
        ilowt(1) = icrs
        ihigt(1) = 1
      Else
        ilowt(1) = 1
        ihigt(1) = icrs
      End If
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    If (ndon <= icrs) Then
      nord = min(nord, 2)
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      Return
    End If
    !
    icrs = icrs + 1
    jhig = 1
    If (xdont(icrs) < xdont(ihigt(1))) Then
      If (xdont(icrs) < xdont(ilowt(1))) Then
        jhig = jhig + 1
        ihigt(jhig) = ihigt(1)
        ihigt(1) = ilowt(1)
        ilowt(1) = icrs
      Else If (xdont(icrs) > xdont(ilowt(1))) Then
        jhig = jhig + 1
        ihigt(jhig) = ihigt(1)
        ihigt(1) = icrs
      End If
    ElseIf (xdont(icrs) > xdont(ihigt(1))) Then
      jhig = jhig + 1
      ihigt(jhig) = icrs
    End If
    !
    If (ndon <= icrs) Then
      nord = min(nord, jhig + 1)
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      Return
    End If
    !
    If (xdont(ndon) < xdont(ihigt(1))) Then
      If (xdont(ndon) < xdont(ilowt(1))) Then
        Do idcr = jhig, 1, -1
          ihigt(idcr + 1) = ihigt(idcr)
        End Do
        ihigt(1) = ilowt(1)
        ilowt(1) = ndon
        jhig = jhig + 1
      ElseIf (xdont(ndon) > xdont(ilowt(1))) Then
        Do idcr = jhig, 1, -1
          ihigt(idcr + 1) = ihigt(idcr)
        End Do
        ihigt(1) = ndon
        jhig = jhig + 1
      End If
    ElseIf (xdont(ndon) > xdont(ihigt(1))) Then
      jhig = jhig + 1
      ihigt(jhig) = ndon
    End If
    !
    If (ndon <= icrs + 1) Then
      nord = min(nord, jhig + 1)
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      If (nord >= 4) irngt(4) = ihigt(3)
      Return
    End If
    !
    jdeb = 0
    ideb = jdeb + 1
    jlow = ideb
    xpiv = xdont(ilowt(ideb)) + real(2 * nord, sp) / real(ndon + nord, sp) * &
            (xdont(ihigt(3)) - xdont(ilowt(ideb)))
    If (xpiv >= xdont(ihigt(1))) Then
      xpiv = xdont(ilowt(ideb)) + real(2 * nord, sp) / real(ndon + nord, sp) * &
              (xdont(ihigt(2)) - xdont(ilowt(ideb)))
      If (xpiv >= xdont(ihigt(1))) &
              xpiv = xdont(ilowt(ideb)) + real(2 * nord, sp) / real(ndon + nord, sp) * &
                      (xdont(ihigt(1)) - xdont(ilowt(ideb)))
    End If
    xpiv0 = xpiv
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the IHIGT array as soon as we have more
    !  than enough values in ILOWT, i.e. one more than
    !  strictly necessary so as to be able to come out of the
    !  case where JLOWT would be NORD distinct values followed
    !  by values that are exclusively duplicates of these.
    !
    !
    If (xdont(ndon) > xpiv) Then
      lowloop1 : Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          Do ilow = 1, jlow
            If (eq(xdont(icrs), xdont(ilowt(ilow)))) cycle lowloop1
          End Do
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do lowloop1
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            ilowt(jlow) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      lowloop2 : Do icrs = icrs + 1, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          Do ilow = 1, jlow
            If (eq(xdont(icrs), xdont(ilowt(ilow)))) cycle lowloop2
          End Do
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do lowloop2
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            ilowt(jlow) = icrs
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      if (jlow == nord) Exit
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to NORD
        !
        If (nord > jlow) Then
          xmin = xdont(ihigt(1))
          ihig = 1
          Do icrs = 2, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              xmin = xdont(ihigt(icrs))
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          ilowt(jlow) = ihigt(ihig)
          ihig = 0
          Do icrs = 1, jhig
            If (ne(xdont(ihigt(icrs)), xmin)) then
              ihig = ihig + 1
              ihigt(ihig) = ihigt(icrs)
            End If
          End Do
          jhig = ihig
        Else
          ilow = ilowt(jlow)
          xmax = xdont(ilow)
          Do icrs = 1, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              iwrk = ilowt(icrs)
              xmax = xdont(iwrk)
              ilowt(icrs) = ilow
              ilow = iwrk
            End If
          End Do
          jlow = jlow - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to NORD. In order to make better pivot choices, we
      !   decrease NORD if we already know that we don't have that
      !   many distinct values as a whole.
      !
      IF (jlow + jhig < nord) nord = jlow + jhig
      Select Case (nord - jlow)
        ! ______________________________
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        Select Case (jhig)
          !
          !   Not enough values in high part either (too many duplicates)
          !
        Case (0)
          nord = jlow
          !
        Case (1)
          jlow = jlow + 1
          ilowt(jlow) = ihigt(1)
          nord = jlow
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (le(xdont(ihigt(1)), xdont(ihigt(2)))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
          ElseIf (eq(xdont(ihigt(1)), xdont(ihigt(2)))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            nord = jlow
          Else
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(3)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(3) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          jhig = 1
          jlow = jlow + 1
          ilowt(jlow) = ihigt(1)
          jhig = jhig + 1
          IF (ne(xdont(ihigt(jhig)), xdont(ilowt(jlow)))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(jhig)
          End If
          jhig = jhig + 1
          IF (ne(xdont(ihigt(jhig)), xdont(ilowt(jlow)))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(jhig)
          End If
          nord = min(jlow, nord)
          Exit
          !
        Case (4 :)
          !
          !
          xpiv0 = xpiv
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(ifin)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(ifin) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          !
          jdeb = jlow
          nwrk = nord - jlow
          iwrk1 = ihigt(1)
          xpiv = xdont(iwrk1) + real(nwrk, sp) / real(nord + nwrk, sp) * &
                  (xdont(ihigt(ifin)) - xdont(iwrk1))
          !
          !  One takes values <= pivot to ILOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          lowloop3 : Do icrs = 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              Do ilow = 1, jlow
                If (eq(xdont(ihigt(icrs)), xdont(ilowt(ilow)))) &
                        cycle lowloop3
              End Do
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (jlow > nord) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do lowloop3
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            End If
          End Do
        End Select
        !
        ! ______________________________
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xdont(ihigt(1))
        ihig = 1
        Do icrs = 2, jhig
          If (xdont(ihigt(icrs)) < xmin) Then
            xmin = xdont(ihigt(icrs))
            ihig = icrs
          End If
        End Do
        !
        jlow = jlow + 1
        ilowt(jlow) = ihigt(ihig)
        Exit
        !
        ! ______________________________
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        ! ______________________________
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        irngt(1) = ilowt(1)
        Do icrs = 2, nord
          iwrk = ilowt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk < xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
        End Do
        !
        xwrk1 = xdont(irngt(nord))
        insert1 : Do icrs = nord + 1, jlow
          If (xdont(ilowt(icrs)) < xwrk1) Then
            xwrk = xdont(ilowt(icrs))
            Do ilow = 1, nord - 1
              If (xwrk <= xdont(irngt(ilow))) Then
                If (eq(xwrk, xdont(irngt(ilow)))) cycle insert1
                Exit
              End If
            End Do
            Do idcr = nord - 1, ilow, - 1
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ilowt(icrs)
            xwrk1 = xdont(irngt(nord))
          End If
        End Do insert1
        !
        Return
        !
        ! ______________________________
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
        ideb = jdeb + 1
        imil = min((jlow + ideb) / 2, nord)
        ifin = min(jlow, nord + 1)
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
          iwrk = ilowt(ideb)
          ilowt(ideb) = ilowt(imil)
          ilowt(imil) = iwrk
        End If
        If (xdont(ilowt(imil)) > xdont(ilowt(ifin))) Then
          iwrk = ilowt(ifin)
          ilowt(ifin) = ilowt(imil)
          ilowt(imil) = iwrk
          If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
            iwrk = ilowt(ideb)
            ilowt(ideb) = ilowt(imil)
            ilowt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xdont(ilowt(ideb)) + real(nord, sp) / real(jlow + nord, sp) * &
                (xdont(ilowt(ifin)) - xdont(ilowt(1)))
        If (jdeb > 0) Then
          If (xpiv <= xpiv0) &
                  xpiv = xpiv0 + real(2 * nord - jdeb, sp) / real(jlow + nord, sp) * &
                          (xdont(ilowt(ifin)) - xpiv0)
        Else
          ideb = 1
        End If
        !
        !  One takes values > XPIV to IHIGT
        !  However, we do not process the first values if we have been
        !  through the case when we did not have enough low values
        !
        jhig = 0
        ifin = jlow
        jlow = jdeb
        !
        If (xdont(ilowt(ifin)) > xpiv) Then
          icrs = jdeb
          lowloop4 : Do
            icrs = icrs + 1
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (icrs >= ifin) Exit
            Else
              xwrk1 = xdont(ilowt(icrs))
              Do ilow = ideb, jlow
                If (eq(xwrk1, xdont(ilowt(ilow)))) &
                        cycle lowloop4
              End Do
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do lowloop4
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ilowt(icrs)) <= xpiv) Then
                jlow = jlow + 1
                ilowt(jlow) = ilowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          lowloop5 : Do icrs = ideb, ifin
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            Else
              xwrk1 = xdont(ilowt(icrs))
              Do ilow = ideb, jlow
                If (eq(xwrk1, xdont(ilowt(ilow)))) &
                        cycle lowloop5
              End Do
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do lowloop5
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      ! ______________________________
      !
    End Do
    !
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    irngt(1) = ilowt(1)
    Do icrs = 2, nord
      iwrk = ilowt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk < xdont(irngt(idcr))) Then
          irngt(idcr + 1) = irngt(idcr)
        Else
          Exit
        End If
      End Do
      irngt(idcr + 1) = iwrk
    End Do
    Return
    !
    !
  End Subroutine r_unipar
 
  Subroutine i_unipar (XDONT, IRNGT, NORD)
    !  Ranks partially XDONT by IRNGT, up to order NORD at most,
    !  removing duplicate entries
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  quickly as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then uses an insertion sort to rank
    !  this set, since it is supposedly small. At all times, the
    !  NORD first values in ILOWT correspond to distinct values
    !  of the input array.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (InOut) :: NORD
    ! __________________________________________________________
    Integer(kind = i4) :: XPIV, XWRK, XWRK1, XMIN, XMAX, XPIV0
    !
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: ILOWT, IHIGT
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG, IWRK, IWRK1, IWRK2, IWRK3
    Integer(kind = i4) :: IDEB, JDEB, IMIL, IFIN, NWRK, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1
    !
    ndon = SIZE (xdont)
    !
    !    First loop is used to fill-in ILOWT, IHIGT at the same time
    !
    If (ndon < 2) Then
      If (nord >= 1) Then
        nord = 1
        irngt(1) = 1
      End If
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    Do icrs = 2, ndon
      If (xdont(icrs) == xdont(1)) Then
        cycle
      Else If (xdont(icrs) < xdont(1)) Then
        ilowt(1) = icrs
        ihigt(1) = 1
      Else
        ilowt(1) = 1
        ihigt(1) = icrs
      End If
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    If (ndon <= icrs) Then
      nord = min(nord, 2)
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      Return
    End If
    !
    icrs = icrs + 1
    jhig = 1
    If (xdont(icrs) < xdont(ihigt(1))) Then
      If (xdont(icrs) < xdont(ilowt(1))) Then
        jhig = jhig + 1
        ihigt(jhig) = ihigt(1)
        ihigt(1) = ilowt(1)
        ilowt(1) = icrs
      Else If (xdont(icrs) > xdont(ilowt(1))) Then
        jhig = jhig + 1
        ihigt(jhig) = ihigt(1)
        ihigt(1) = icrs
      End If
    ElseIf (xdont(icrs) > xdont(ihigt(1))) Then
      jhig = jhig + 1
      ihigt(jhig) = icrs
    End If
    !
    If (ndon <= icrs) Then
      nord = min(nord, jhig + 1)
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      Return
    End If
    !
    If (xdont(ndon) < xdont(ihigt(1))) Then
      If (xdont(ndon) < xdont(ilowt(1))) Then
        Do idcr = jhig, 1, -1
          ihigt(idcr + 1) = ihigt(idcr)
        End Do
        ihigt(1) = ilowt(1)
        ilowt(1) = ndon
        jhig = jhig + 1
      ElseIf (xdont(ndon) > xdont(ilowt(1))) Then
        Do idcr = jhig, 1, -1
          ihigt(idcr + 1) = ihigt(idcr)
        End Do
        ihigt(1) = ndon
        jhig = jhig + 1
      End If
    ElseIf (xdont(ndon) > xdont(ihigt(1))) Then
      jhig = jhig + 1
      ihigt(jhig) = ndon
    End If
    !
    If (ndon <= icrs + 1) Then
      nord = min(nord, jhig + 1)
      If (nord >= 1) irngt(1) = ilowt(1)
      If (nord >= 2) irngt(2) = ihigt(1)
      If (nord >= 3) irngt(3) = ihigt(2)
      If (nord >= 4) irngt(4) = ihigt(3)
      Return
    End If
    !
    jdeb = 0
    ideb = jdeb + 1
    jlow = ideb
    xpiv = xdont(ilowt(ideb)) + int(real(2 * nord, sp) / real(ndon + nord, sp), i4) * &
            (xdont(ihigt(3)) - xdont(ilowt(ideb)))
    If (xpiv >= xdont(ihigt(1))) Then
      xpiv = xdont(ilowt(ideb)) + int(real(2 * nord, sp) / real(ndon + nord, sp), i4) * &
              (xdont(ihigt(2)) - xdont(ilowt(ideb)))
      If (xpiv >= xdont(ihigt(1))) &
              xpiv = xdont(ilowt(ideb)) + int(real(2 * nord, sp) / real(ndon + nord, sp), i4) * &
                      (xdont(ihigt(1)) - xdont(ilowt(ideb)))
    End If
    xpiv0 = xpiv
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the IHIGT array as soon as we have more
    !  than enough values in ILOWT, i.e. one more than
    !  strictly necessary so as to be able to come out of the
    !  case where JLOWT would be NORD distinct values followed
    !  by values that are exclusively duplicates of these.
    !
    !
    If (xdont(ndon) > xpiv) Then
      lowloop1 : Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          Do ilow = 1, jlow
            If (xdont(icrs) == xdont(ilowt(ilow))) cycle lowloop1
          End Do
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do lowloop1
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            ilowt(jlow) = icrs
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      lowloop2 : Do icrs = icrs + 1, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          ihigt(jhig) = icrs
        Else
          Do ilow = 1, jlow
            If (xdont(icrs) == xdont(ilowt(ilow))) cycle lowloop2
          End Do
          jlow = jlow + 1
          ilowt(jlow) = icrs
          If (jlow >= nord) Exit
        End If
      End Do lowloop2
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            ilowt(jlow) = icrs
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      if (jlow == nord) Exit
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to NORD
        !
        If (nord > jlow) Then
          xmin = xdont(ihigt(1))
          ihig = 1
          Do icrs = 2, jhig
            If (xdont(ihigt(icrs)) < xmin) Then
              xmin = xdont(ihigt(icrs))
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          ilowt(jlow) = ihigt(ihig)
          ihig = 0
          Do icrs = 1, jhig
            If (xdont(ihigt(icrs)) /= xmin) then
              ihig = ihig + 1
              ihigt(ihig) = ihigt(icrs)
            End If
          End Do
          jhig = ihig
        Else
          ilow = ilowt(jlow)
          xmax = xdont(ilow)
          Do icrs = 1, jlow
            If (xdont(ilowt(icrs)) > xmax) Then
              iwrk = ilowt(icrs)
              xmax = xdont(iwrk)
              ilowt(icrs) = ilow
              ilow = iwrk
            End If
          End Do
          jlow = jlow - 1
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to NORD. In order to make better pivot choices, we
      !   decrease NORD if we already know that we don't have that
      !   many distinct values as a whole.
      !
      IF (jlow + jhig < nord) nord = jlow + jhig
      Select Case (nord - jlow)
        ! ______________________________
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        Select Case (jhig)
          !
          !   Not enough values in high part either (too many duplicates)
          !
        Case (0)
          nord = jlow
          !
        Case (1)
          jlow = jlow + 1
          ilowt(jlow) = ihigt(1)
          nord = jlow
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xdont(ihigt(1)) <= xdont(ihigt(2))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
          ElseIf (xdont(ihigt(1)) == xdont(ihigt(2))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
            nord = jlow
          Else
            jlow = jlow + 1
            ilowt(jlow) = ihigt(2)
            jlow = jlow + 1
            ilowt(jlow) = ihigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(3)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(3) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          jhig = 1
          jlow = jlow + 1
          ilowt(jlow) = ihigt(1)
          jhig = jhig + 1
          IF (xdont(ihigt(jhig)) /= xdont(ilowt(jlow))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(jhig)
          End If
          jhig = jhig + 1
          IF (xdont(ihigt(jhig)) /= xdont(ilowt(jlow))) Then
            jlow = jlow + 1
            ilowt(jlow) = ihigt(jhig)
          End If
          nord = min(jlow, nord)
          Exit
          !
        Case (4 :)
          !
          !
          xpiv0 = xpiv
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          iwrk1 = ihigt(1)
          iwrk2 = ihigt(2)
          iwrk3 = ihigt(ifin)
          If (xdont(iwrk2) < xdont(iwrk1)) Then
            ihigt(1) = iwrk2
            ihigt(2) = iwrk1
            iwrk2 = iwrk1
          End If
          If (xdont(iwrk2) > xdont(iwrk3)) Then
            ihigt(ifin) = iwrk2
            ihigt(2) = iwrk3
            iwrk2 = iwrk3
            If (xdont(iwrk2) < xdont(ihigt(1))) Then
              ihigt(2) = ihigt(1)
              ihigt(1) = iwrk2
            End If
          End If
          !
          jdeb = jlow
          nwrk = nord - jlow
          iwrk1 = ihigt(1)
          xpiv = xdont(iwrk1) + int(real(nwrk, sp) / real(nord + nwrk, sp), i4) * &
                  (xdont(ihigt(ifin)) - xdont(iwrk1))
          !
          !  One takes values <= pivot to ILOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          lowloop3 : Do icrs = 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              Do ilow = 1, jlow
                If (xdont(ihigt(icrs)) == xdont(ilowt(ilow))) &
                        cycle lowloop3
              End Do
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
              If (jlow > nord) Exit
            Else
              jhig = jhig + 1
              ihigt(jhig) = ihigt(icrs)
            End If
          End Do lowloop3
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ihigt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ihigt(icrs)
            End If
          End Do
        End Select
        !
        ! ______________________________
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xdont(ihigt(1))
        ihig = 1
        Do icrs = 2, jhig
          If (xdont(ihigt(icrs)) < xmin) Then
            xmin = xdont(ihigt(icrs))
            ihig = icrs
          End If
        End Do
        !
        jlow = jlow + 1
        ilowt(jlow) = ihigt(ihig)
        Exit
        !
        ! ______________________________
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        ! ______________________________
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        irngt(1) = ilowt(1)
        Do icrs = 2, nord
          iwrk = ilowt(icrs)
          xwrk = xdont(iwrk)
          Do idcr = icrs - 1, 1, - 1
            If (xwrk < xdont(irngt(idcr))) Then
              irngt(idcr + 1) = irngt(idcr)
            Else
              Exit
            End If
          End Do
          irngt(idcr + 1) = iwrk
        End Do
        !
        xwrk1 = xdont(irngt(nord))
        insert1 : Do icrs = nord + 1, jlow
          If (xdont(ilowt(icrs)) < xwrk1) Then
            xwrk = xdont(ilowt(icrs))
            Do ilow = 1, nord - 1
              If (xwrk <= xdont(irngt(ilow))) Then
                If (xwrk == xdont(irngt(ilow))) cycle insert1
                Exit
              End If
            End Do
            Do idcr = nord - 1, ilow, - 1
              irngt(idcr + 1) = irngt(idcr)
            End Do
            irngt(idcr + 1) = ilowt(icrs)
            xwrk1 = xdont(irngt(nord))
          End If
        End Do insert1
        !
        Return
        !
        ! ______________________________
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
        ideb = jdeb + 1
        imil = min((jlow + ideb) / 2, nord)
        ifin = min(jlow, nord + 1)
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
          iwrk = ilowt(ideb)
          ilowt(ideb) = ilowt(imil)
          ilowt(imil) = iwrk
        End If
        If (xdont(ilowt(imil)) > xdont(ilowt(ifin))) Then
          iwrk = ilowt(ifin)
          ilowt(ifin) = ilowt(imil)
          ilowt(imil) = iwrk
          If (xdont(ilowt(imil)) < xdont(ilowt(ideb))) Then
            iwrk = ilowt(ideb)
            ilowt(ideb) = ilowt(imil)
            ilowt(imil) = iwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xdont(ilowt(ideb)) + int(real(nord, sp) / real(jlow + nord, sp), i4) * &
                (xdont(ilowt(ifin)) - xdont(ilowt(1)))
        If (jdeb > 0) Then
          If (xpiv <= xpiv0) &
                  xpiv = xpiv0 + int(real(2 * nord - jdeb, sp) / real(jlow + nord, sp), i4) * &
                          (xdont(ilowt(ifin)) - xpiv0)
        Else
          ideb = 1
        End If
        !
        !  One takes values > XPIV to IHIGT
        !  However, we do not process the first values if we have been
        !  through the case when we did not have enough low values
        !
        jhig = 0
        ifin = jlow
        jlow = jdeb
        !
        If (xdont(ilowt(ifin)) > xpiv) Then
          icrs = jdeb
          lowloop4 : Do
            icrs = icrs + 1
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
              If (icrs >= ifin) Exit
            Else
              xwrk1 = xdont(ilowt(icrs))
              Do ilow = ideb, jlow
                If (xwrk1 == xdont(ilowt(ilow))) &
                        cycle lowloop4
              End Do
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do lowloop4
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xdont(ilowt(icrs)) <= xpiv) Then
                jlow = jlow + 1
                ilowt(jlow) = ilowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          lowloop5 : Do icrs = ideb, ifin
            If (xdont(ilowt(icrs)) > xpiv) Then
              jhig = jhig + 1
              ihigt(jhig) = ilowt(icrs)
            Else
              xwrk1 = xdont(ilowt(icrs))
              Do ilow = ideb, jlow
                If (xwrk1 == xdont(ilowt(ilow))) &
                        cycle lowloop5
              End Do
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
              If (jlow >= nord) Exit
            End If
          End Do lowloop5
          !
          Do icrs = icrs + 1, ifin
            If (xdont(ilowt(icrs)) <= xpiv) Then
              jlow = jlow + 1
              ilowt(jlow) = ilowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      ! ______________________________
      !
    End Do
    !
    !  Now, we only need to complete ranking of the 1:NORD set
    !  Assuming NORD is small, we use a simple insertion sort
    !
    irngt(1) = ilowt(1)
    Do icrs = 2, nord
      iwrk = ilowt(icrs)
      xwrk = xdont(iwrk)
      Do idcr = icrs - 1, 1, - 1
        If (xwrk < xdont(irngt(idcr))) Then
          irngt(idcr + 1) = irngt(idcr)
        Else
          Exit
        End If
      End Do
      irngt(idcr + 1) = iwrk
    End Do
    Return
    !
    !
  End Subroutine i_unipar
 
  Subroutine d_unirnk (XVALT, IRNGT, NUNI)
    ! __________________________________________________________
    !   UNIRNK = Merge-sort ranking of an array, with removal of
    !   duplicate entries.
    !   The routine is similar to pure merge-sort ranking, but on
    !   the last pass, it discards indices that correspond to
    !   duplicate entries.
    !   For performance reasons, the first 2 passes are taken
    !   out of the standard loop, and use dedicated coding.
    ! __________________________________________________________
    ! __________________________________________________________
    real(Kind = dp), Dimension (:), Intent (In) :: xvalt
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (Out) :: NUNI
    ! __________________________________________________________
    Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
    Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    real(Kind = dp) :: xtst, xvala, xvalb
    !
    !
    nval = min(SIZE(xvalt), SIZE(irngt))
    nuni = nval
    !
    Select Case (nval)
    Case (: 0)
      Return
    Case (1)
      irngt(1) = 1
      Return
    Case Default
 
    End Select
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xvalt(iind - 1) < xvalt(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    lmtna = 2
    lmtnc = 4
    !
    !  First iteration. The length of the ordered subsets goes from 2 to 4
    !
    Do
      If (nval <= 4) Exit
      !
      !   Loop on merges of A and B into C
      !
      Do iwrkd = 0, nval - 1, 4
        If ((iwrkd + 4) > nval) Then
          If ((iwrkd + 2) >= nval) Exit
          !
          !   1 2 3
          !
          If (xvalt(irngt(iwrkd + 2)) <= xvalt(irngt(iwrkd + 3))) Exit
          !
          !   1 3 2
          !
          If (xvalt(irngt(iwrkd + 1)) <= xvalt(irngt(iwrkd + 3))) Then
            irng2 = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irng2
            !
            !   3 1 2
            !
          Else
            irng1 = irngt(iwrkd + 1)
            irngt(iwrkd + 1) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irng1
          End If
          If (.true.) Exit   ! Exit ! JM
        End If
        !
        !   1 2 3 4
        !
        If (xvalt(irngt(iwrkd + 2)) <= xvalt(irngt(iwrkd + 3))) cycle
        !
        !   1 3 x x
        !
        If (xvalt(irngt(iwrkd + 1)) <= xvalt(irngt(iwrkd + 3))) Then
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 2) = irngt(iwrkd + 3)
          If (xvalt(irng2) <= xvalt(irngt(iwrkd + 4))) Then
            !   1 3 2 4
            irngt(iwrkd + 3) = irng2
          Else
            !   1 3 4 2
            irngt(iwrkd + 3) = irngt(iwrkd + 4)
            irngt(iwrkd + 4) = irng2
          End If
          !
          !   3 x x x
          !
        Else
          irng1 = irngt(iwrkd + 1)
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 1) = irngt(iwrkd + 3)
          If (xvalt(irng1) <= xvalt(irngt(iwrkd + 4))) Then
            irngt(iwrkd + 2) = irng1
            If (xvalt(irng2) <= xvalt(irngt(iwrkd + 4))) Then
              !   3 1 2 4
              irngt(iwrkd + 3) = irng2
            Else
              !   3 1 4 2
              irngt(iwrkd + 3) = irngt(iwrkd + 4)
              irngt(iwrkd + 4) = irng2
            End If
          Else
            !   3 4 1 2
            irngt(iwrkd + 2) = irngt(iwrkd + 4)
            irngt(iwrkd + 3) = irng1
            irngt(iwrkd + 4) = irng2
          End If
        End If
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 4
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    !  Iteration loop. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (2 * lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      !
      !   Loop on merges of A and B into C
      !
      Do
        iwrk = iwrkf
        iwrkd = iwrkf + 1
        jinda = iwrkf + lmtna
        iwrkf = iwrkf + lmtnc
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iinda = 1
        iindb = jinda + 1
        !
        !  One steps in the C subset, that we create in the final rank array
        !
        !  Make a copy of the rank array for the iteration
        !
        jwrkt(1 : lmtna) = irngt(iwrkd : jinda)
        xvala = xvalt(jwrkt(iinda))
        xvalb = xvalt(irngt(iindb))
        !
        Do
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (xvala > xvalb) Then
            irngt(iwrk) = irngt(iindb)
            iindb = iindb + 1
            If (iindb > iwrkf) Then
              !  Only A still with unprocessed values
              irngt(iwrk + 1 : iwrkf) = jwrkt(iinda : lmtna)
              Exit
            End If
            xvalb = xvalt(irngt(iindb))
          Else
            irngt(iwrk) = jwrkt(iinda)
            iinda = iinda + 1
            If (iinda > lmtna) exit! Only B still with unprocessed values
            xvala = xvalt(jwrkt(iinda))
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    !   Last merge of A and B into C, with removal of duplicates.
    !
    iinda = 1
    iindb = lmtna + 1
    nuni = 0
    !
    !  One steps in the C subset, that we create in the final rank array
    !
    jwrkt(1 : lmtna) = irngt(1 : lmtna)
    If (iindb <= nval) Then
      xtst = nearless(min(xvalt(jwrkt(1)), xvalt(irngt(iindb))))
    Else
      xtst = nearless(xvalt(jwrkt(1)))
    end if
    Do iwrk = 1, nval
      !
      !  We still have unprocessed values in both A and B
      !
      If (iinda <= lmtna) Then
        If (iindb <= nval) Then
          If (xvalt(jwrkt(iinda)) > xvalt(irngt(iindb))) Then
            irng = irngt(iindb)
            iindb = iindb + 1
          Else
            irng = jwrkt(iinda)
            iinda = iinda + 1
          End If
        Else
          !
          !  Only A still with unprocessed values
          !
          irng = jwrkt(iinda)
          iinda = iinda + 1
        End If
      Else
        !
        !  Only B still with unprocessed values
        !
        irng = irngt(iwrk)
      End If
      If (xvalt(irng) > xtst) Then
        xtst = xvalt(irng)
        nuni = nuni + 1
        irngt(nuni) = irng
      End If
      !
    End Do
    !
    Return
    !
  End Subroutine d_unirnk
 
  Subroutine r_unirnk (XVALT, IRNGT, NUNI)
    ! __________________________________________________________
    !   UNIRNK = Merge-sort ranking of an array, with removal of
    !   duplicate entries.
    !   The routine is similar to pure merge-sort ranking, but on
    !   the last pass, it discards indices that correspond to
    !   duplicate entries.
    !   For performance reasons, the first 2 passes are taken
    !   out of the standard loop, and use dedicated coding.
    ! __________________________________________________________
    ! __________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xvalt
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (Out) :: NUNI
    ! __________________________________________________________
    Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
    Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    Real(kind = sp) :: xtst, xvala, xvalb
    !
    !
    nval = min(SIZE(xvalt), SIZE(irngt))
    nuni = nval
    !
    Select Case (nval)
    Case (: 0)
      Return
    Case (1)
      irngt(1) = 1
      Return
    Case Default
 
    End Select
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xvalt(iind - 1) < xvalt(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    lmtna = 2
    lmtnc = 4
    !
    !  First iteration. The length of the ordered subsets goes from 2 to 4
    !
    Do
      If (nval <= 4) Exit
      !
      !   Loop on merges of A and B into C
      !
      Do iwrkd = 0, nval - 1, 4
        If ((iwrkd + 4) > nval) Then
          If ((iwrkd + 2) >= nval) Exit
          !
          !   1 2 3
          !
          If (xvalt(irngt(iwrkd + 2)) <= xvalt(irngt(iwrkd + 3))) Exit
          !
          !   1 3 2
          !
          If (xvalt(irngt(iwrkd + 1)) <= xvalt(irngt(iwrkd + 3))) Then
            irng2 = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irng2
            !
            !   3 1 2
            !
          Else
            irng1 = irngt(iwrkd + 1)
            irngt(iwrkd + 1) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irng1
          End If
          If (.true.) Exit   ! Exit ! JM
        End If
        !
        !   1 2 3 4
        !
        If (xvalt(irngt(iwrkd + 2)) <= xvalt(irngt(iwrkd + 3))) cycle
        !
        !   1 3 x x
        !
        If (xvalt(irngt(iwrkd + 1)) <= xvalt(irngt(iwrkd + 3))) Then
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 2) = irngt(iwrkd + 3)
          If (xvalt(irng2) <= xvalt(irngt(iwrkd + 4))) Then
            !   1 3 2 4
            irngt(iwrkd + 3) = irng2
          Else
            !   1 3 4 2
            irngt(iwrkd + 3) = irngt(iwrkd + 4)
            irngt(iwrkd + 4) = irng2
          End If
          !
          !   3 x x x
          !
        Else
          irng1 = irngt(iwrkd + 1)
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 1) = irngt(iwrkd + 3)
          If (xvalt(irng1) <= xvalt(irngt(iwrkd + 4))) Then
            irngt(iwrkd + 2) = irng1
            If (xvalt(irng2) <= xvalt(irngt(iwrkd + 4))) Then
              !   3 1 2 4
              irngt(iwrkd + 3) = irng2
            Else
              !   3 1 4 2
              irngt(iwrkd + 3) = irngt(iwrkd + 4)
              irngt(iwrkd + 4) = irng2
            End If
          Else
            !   3 4 1 2
            irngt(iwrkd + 2) = irngt(iwrkd + 4)
            irngt(iwrkd + 3) = irng1
            irngt(iwrkd + 4) = irng2
          End If
        End If
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 4
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    !  Iteration loop. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (2 * lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      !
      !   Loop on merges of A and B into C
      !
      Do
        iwrk = iwrkf
        iwrkd = iwrkf + 1
        jinda = iwrkf + lmtna
        iwrkf = iwrkf + lmtnc
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iinda = 1
        iindb = jinda + 1
        !
        !  One steps in the C subset, that we create in the final rank array
        !
        !  Make a copy of the rank array for the iteration
        !
        jwrkt(1 : lmtna) = irngt(iwrkd : jinda)
        xvala = xvalt(jwrkt(iinda))
        xvalb = xvalt(irngt(iindb))
        !
        Do
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (xvala > xvalb) Then
            irngt(iwrk) = irngt(iindb)
            iindb = iindb + 1
            If (iindb > iwrkf) Then
              !  Only A still with unprocessed values
              irngt(iwrk + 1 : iwrkf) = jwrkt(iinda : lmtna)
              Exit
            End If
            xvalb = xvalt(irngt(iindb))
          Else
            irngt(iwrk) = jwrkt(iinda)
            iinda = iinda + 1
            If (iinda > lmtna) exit! Only B still with unprocessed values
            xvala = xvalt(jwrkt(iinda))
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    !   Last merge of A and B into C, with removal of duplicates.
    !
    iinda = 1
    iindb = lmtna + 1
    nuni = 0
    !
    !  One steps in the C subset, that we create in the final rank array
    !
    jwrkt(1 : lmtna) = irngt(1 : lmtna)
    If (iindb <= nval) Then
      xtst = nearless(min(xvalt(jwrkt(1)), xvalt(irngt(iindb))))
    Else
      xtst = nearless(xvalt(jwrkt(1)))
    end if
    Do iwrk = 1, nval
      !
      !  We still have unprocessed values in both A and B
      !
      If (iinda <= lmtna) Then
        If (iindb <= nval) Then
          If (xvalt(jwrkt(iinda)) > xvalt(irngt(iindb))) Then
            irng = irngt(iindb)
            iindb = iindb + 1
          Else
            irng = jwrkt(iinda)
            iinda = iinda + 1
          End If
        Else
          !
          !  Only A still with unprocessed values
          !
          irng = jwrkt(iinda)
          iinda = iinda + 1
        End If
      Else
        !
        !  Only B still with unprocessed values
        !
        irng = irngt(iwrk)
      End If
      If (xvalt(irng) > xtst) Then
        xtst = xvalt(irng)
        nuni = nuni + 1
        irngt(nuni) = irng
      End If
      !
    End Do
    !
    Return
    !
  End Subroutine r_unirnk
 
  Subroutine i_unirnk (XVALT, IRNGT, NUNI)
    ! __________________________________________________________
    !   UNIRNK = Merge-sort ranking of an array, with removal of
    !   duplicate entries.
    !   The routine is similar to pure merge-sort ranking, but on
    !   the last pass, it discards indices that correspond to
    !   duplicate entries.
    !   For performance reasons, the first 2 passes are taken
    !   out of the standard loop, and use dedicated coding.
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XVALT
    Integer(kind = i4), Dimension (:), Intent (Out) :: IRNGT
    Integer(kind = i4), Intent (Out) :: NUNI
    ! __________________________________________________________
    Integer(kind = i4), Dimension (SIZE(IRNGT)) :: JWRKT
    Integer(kind = i4) :: LMTNA, LMTNC, IRNG, IRNG1, IRNG2
    Integer(kind = i4) :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
    Integer(kind = i4) :: XTST, XVALA, XVALB
    !
    !
    nval = min(SIZE(xvalt), SIZE(irngt))
    nuni = nval
    !
    Select Case (nval)
    Case (: 0)
      Return
    Case (1)
      irngt(1) = 1
      Return
    Case Default
 
    End Select
    !
    !  Fill-in the index array, creating ordered couples
    !
    Do iind = 2, nval, 2
      If (xvalt(iind - 1) < xvalt(iind)) Then
        irngt(iind - 1) = iind - 1
        irngt(iind) = iind
      Else
        irngt(iind - 1) = iind
        irngt(iind) = iind - 1
      End If
    End Do
    If (modulo(nval, 2) /= 0) Then
      irngt(nval) = nval
    End If
    !
    !  We will now have ordered subsets A - B - A - B - ...
    !  and merge A and B couples into     C   -   C   - ...
    !
    lmtna = 2
    lmtnc = 4
    !
    !  First iteration. The length of the ordered subsets goes from 2 to 4
    !
    Do
      If (nval <= 4) Exit
      !
      !   Loop on merges of A and B into C
      !
      Do iwrkd = 0, nval - 1, 4
        If ((iwrkd + 4) > nval) Then
          If ((iwrkd + 2) >= nval) Exit
          !
          !   1 2 3
          !
          If (xvalt(irngt(iwrkd + 2)) <= xvalt(irngt(iwrkd + 3))) Exit
          !
          !   1 3 2
          !
          If (xvalt(irngt(iwrkd + 1)) <= xvalt(irngt(iwrkd + 3))) Then
            irng2 = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irng2
            !
            !   3 1 2
            !
          Else
            irng1 = irngt(iwrkd + 1)
            irngt(iwrkd + 1) = irngt(iwrkd + 3)
            irngt(iwrkd + 3) = irngt(iwrkd + 2)
            irngt(iwrkd + 2) = irng1
          End If
          If (.true.) Exit   ! Exit ! JM
        End If
        !
        !   1 2 3 4
        !
        If (xvalt(irngt(iwrkd + 2)) <= xvalt(irngt(iwrkd + 3))) cycle
        !
        !   1 3 x x
        !
        If (xvalt(irngt(iwrkd + 1)) <= xvalt(irngt(iwrkd + 3))) Then
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 2) = irngt(iwrkd + 3)
          If (xvalt(irng2) <= xvalt(irngt(iwrkd + 4))) Then
            !   1 3 2 4
            irngt(iwrkd + 3) = irng2
          Else
            !   1 3 4 2
            irngt(iwrkd + 3) = irngt(iwrkd + 4)
            irngt(iwrkd + 4) = irng2
          End If
          !
          !   3 x x x
          !
        Else
          irng1 = irngt(iwrkd + 1)
          irng2 = irngt(iwrkd + 2)
          irngt(iwrkd + 1) = irngt(iwrkd + 3)
          If (xvalt(irng1) <= xvalt(irngt(iwrkd + 4))) Then
            irngt(iwrkd + 2) = irng1
            If (xvalt(irng2) <= xvalt(irngt(iwrkd + 4))) Then
              !   3 1 2 4
              irngt(iwrkd + 3) = irng2
            Else
              !   3 1 4 2
              irngt(iwrkd + 3) = irngt(iwrkd + 4)
              irngt(iwrkd + 4) = irng2
            End If
          Else
            !   3 4 1 2
            irngt(iwrkd + 2) = irngt(iwrkd + 4)
            irngt(iwrkd + 3) = irng1
            irngt(iwrkd + 4) = irng2
          End If
        End If
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 4
      If (.true.) Exit   ! Exit ! JM
    End Do
    !
    !  Iteration loop. Each time, the length of the ordered subsets
    !  is doubled.
    !
    Do
      If (2 * lmtna >= nval) Exit
      iwrkf = 0
      lmtnc = 2 * lmtnc
      !
      !   Loop on merges of A and B into C
      !
      Do
        iwrk = iwrkf
        iwrkd = iwrkf + 1
        jinda = iwrkf + lmtna
        iwrkf = iwrkf + lmtnc
        If (iwrkf >= nval) Then
          If (jinda >= nval) Exit
          iwrkf = nval
        End If
        iinda = 1
        iindb = jinda + 1
        !
        !  One steps in the C subset, that we create in the final rank array
        !
        !  Make a copy of the rank array for the iteration
        !
        jwrkt(1 : lmtna) = irngt(iwrkd : jinda)
        xvala = xvalt(jwrkt(iinda))
        xvalb = xvalt(irngt(iindb))
        !
        Do
          iwrk = iwrk + 1
          !
          !  We still have unprocessed values in both A and B
          !
          If (xvala > xvalb) Then
            irngt(iwrk) = irngt(iindb)
            iindb = iindb + 1
            If (iindb > iwrkf) Then
              !  Only A still with unprocessed values
              irngt(iwrk + 1 : iwrkf) = jwrkt(iinda : lmtna)
              Exit
            End If
            xvalb = xvalt(irngt(iindb))
          Else
            irngt(iwrk) = jwrkt(iinda)
            iinda = iinda + 1
            If (iinda > lmtna) exit! Only B still with unprocessed values
            xvala = xvalt(jwrkt(iinda))
          End If
          !
        End Do
      End Do
      !
      !  The Cs become As and Bs
      !
      lmtna = 2 * lmtna
    End Do
    !
    !   Last merge of A and B into C, with removal of duplicates.
    !
    iinda = 1
    iindb = lmtna + 1
    nuni = 0
    !
    !  One steps in the C subset, that we create in the final rank array
    !
    jwrkt(1 : lmtna) = irngt(1 : lmtna)
    If (iindb <= nval) Then
      xtst = nearless(min(xvalt(jwrkt(1)), xvalt(irngt(iindb))))
    Else
      xtst = nearless(xvalt(jwrkt(1)))
    end if
    Do iwrk = 1, nval
      !
      !  We still have unprocessed values in both A and B
      !
      If (iinda <= lmtna) Then
        If (iindb <= nval) Then
          If (xvalt(jwrkt(iinda)) > xvalt(irngt(iindb))) Then
            irng = irngt(iindb)
            iindb = iindb + 1
          Else
            irng = jwrkt(iinda)
            iinda = iinda + 1
          End If
        Else
          !
          !  Only A still with unprocessed values
          !
          irng = jwrkt(iinda)
          iinda = iinda + 1
        End If
      Else
        !
        !  Only B still with unprocessed values
        !
        irng = irngt(iwrk)
      End If
      If (xvalt(irng) > xtst) Then
        xtst = xvalt(irng)
        nuni = nuni + 1
        irngt(nuni) = irng
      End If
      !
    End Do
    !
    Return
    !
  End Subroutine i_unirnk
 
 
  Subroutine d_unista (XDONT, NUNI)
    !   UNISTA = (Stable unique) Removes duplicates from an array,
    !            leaving unique entries in the order of their first
    !            appearance in the initial set.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (InOut) :: xdont
    Integer(kind = i4), Intent (Out) :: NUNI
    ! __________________________________________________________
    !
    Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
    Logical, Dimension (Size(XDONT)) :: IFMPTYT
    Integer(kind = i4) :: ICRS
    ! __________________________________________________________
    Call uniinv (xdont, iwrkt)
    ifmptyt = .true.
    nuni = 0
    Do icrs = 1, Size(xdont)
      If (ifmptyt(iwrkt(icrs))) Then
        ifmptyt(iwrkt(icrs)) = .false.
        nuni = nuni + 1
        xdont(nuni) = xdont(icrs)
      End If
    End Do
    Return
    !
  End Subroutine d_unista
 
  Subroutine r_unista (XDONT, NUNI)
    !   UNISTA = (Stable unique) Removes duplicates from an array,
    !            leaving unique entries in the order of their first
    !            appearance in the initial set.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (InOut) :: xdont
    Integer(kind = i4), Intent (Out) :: NUNI
    ! __________________________________________________________
    !
    Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
    Logical, Dimension (Size(XDONT)) :: IFMPTYT
    Integer(kind = i4) :: ICRS
    ! __________________________________________________________
    Call uniinv (xdont, iwrkt)
    ifmptyt = .true.
    nuni = 0
    Do icrs = 1, Size(xdont)
      If (ifmptyt(iwrkt(icrs))) Then
        ifmptyt(iwrkt(icrs)) = .false.
        nuni = nuni + 1
        xdont(nuni) = xdont(icrs)
      End If
    End Do
    Return
    !
  End Subroutine r_unista
 
  Subroutine i_unista (XDONT, NUNI)
    !   UNISTA = (Stable unique) Removes duplicates from an array,
    !            leaving unique entries in the order of their first
    !            appearance in the initial set.
    !  Michel Olagnon - Feb. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (InOut) :: XDONT
    Integer(kind = i4), Intent (Out) :: NUNI
    ! __________________________________________________________
    !
    Integer(kind = i4), Dimension (Size(XDONT)) :: IWRKT
    Logical, Dimension (Size(XDONT)) :: IFMPTYT
    Integer(kind = i4) :: ICRS
    ! __________________________________________________________
    Call uniinv (xdont, iwrkt)
    ifmptyt = .true.
    nuni = 0
    Do icrs = 1, Size(xdont)
      If (ifmptyt(iwrkt(icrs))) Then
        ifmptyt(iwrkt(icrs)) = .false.
        nuni = nuni + 1
        xdont(nuni) = xdont(icrs)
      End If
    End Do
    Return
    !
  End Subroutine i_unista
 
  Recursive Function d_valmed (XDONT) Result (res_med)
    !  Finds the median of XDONT using the recursive procedure
    !  described in Knuth, The Art of Computer Programming,
    !  vol. 3, 5.3.3 - This procedure is linear in time, and
    !  does not require to be able to interpolate in the
    !  set as the one used in INDNTH. It also has better worst
    !  case behavior than INDNTH, but is about 30% slower in
    !  average for random uniformly distributed values.
    ! __________________________________________________________
    ! __________________________________________________________
    real(kind = dp), Dimension (:), Intent (In) :: xdont
    real(kind = dp) :: res_med
    ! __________________________________________________________
    real(kind = dp), Parameter :: xhuge = huge(xdont)
    real(kind = dp), Dimension (SIZE(XDONT) + 6) :: xwrkt
    real(kind = dp) :: xwrk, xwrk1, xmed7
    !
    Integer(kind = i4), Dimension ((SIZE(XDONT) + 6) / 7) :: ISTRT, IENDT, IMEDT
    Integer(kind = i4) :: NDON, NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
    Integer(kind = i4) :: IDEB, IWRK, IDCR, ICRS, ICRS1, ICRS2, IMED1
    !
    ndon = SIZE (xdont)
    nmed = (ndon + 1) / 2
    !      write(unit=*,fmt=*) NMED, NDON
    !
    !  If the number of values is small, then use insertion sort
    !
    If (ndon < 35) Then
      !
      !  Bring minimum to first location to save test in decreasing loop
      !
      idcr = ndon
      If (xdont(1) < xdont(ndon)) Then
        xwrk = xdont(1)
        xwrkt(idcr) = xdont(idcr)
      Else
        xwrk = xdont(idcr)
        xwrkt(idcr) = xdont(1)
      end if
      Do iwrk = 1, ndon - 2
        idcr = idcr - 1
        xwrk1 = xdont(idcr)
        If (xwrk1 < xwrk) Then
          xwrkt(idcr) = xwrk
          xwrk = xwrk1
        Else
          xwrkt(idcr) = xwrk1
        end if
      End Do
      xwrkt(1) = xwrk
      !
      ! Sort the first half, until we have NMED sorted values
      !
      Do icrs = 3, nmed
        xwrk = xwrkt(icrs)
        idcr = icrs - 1
        Do
          If (xwrk >= xwrkt(idcr)) Exit
          xwrkt(idcr + 1) = xwrkt(idcr)
          idcr = idcr - 1
        End Do
        xwrkt(idcr + 1) = xwrk
      End Do
      !
      !  Insert any value less than the current median in the first half
      !
      Do icrs = nmed + 1, ndon
        xwrk = xwrkt(icrs)
        If (xwrk < xwrkt(nmed)) Then
          idcr = nmed - 1
          Do
            If (xwrk >= xwrkt(idcr)) Exit
            xwrkt(idcr + 1) = xwrkt(idcr)
            idcr = idcr - 1
          End Do
          xwrkt(idcr + 1) = xwrk
        End If
      End Do
      res_med = xwrkt(nmed)
      Return
    End If
    !
    !  Make sorted subsets of 7 elements
    !  This is done by a variant of insertion sort where a first
    !  pass is used to bring the smallest element to the first position
    !  decreasing disorder at the same time, so that we may remove
    !  remove the loop test in the insertion loop.
    !
    DO ideb = 1, ndon - 6, 7
      idcr = ideb + 6
      If (xdont(ideb) < xdont(idcr)) Then
        xwrk = xdont(ideb)
        xwrkt(idcr) = xdont(idcr)
      Else
        xwrk = xdont(idcr)
        xwrkt(idcr) = xdont(ideb)
      end if
      Do iwrk = 1, 5
        idcr = idcr - 1
        xwrk1 = xdont(idcr)
        If (xwrk1 < xwrk) Then
          xwrkt(idcr) = xwrk
          xwrk = xwrk1
        Else
          xwrkt(idcr) = xwrk1
        end if
      End Do
      xwrkt(ideb) = xwrk
      Do icrs = ideb + 2, ideb + 6
        xwrk = xwrkt(icrs)
        If (xwrk < xwrkt(icrs - 1)) Then
          xwrkt(icrs) = xwrkt(icrs - 1)
          idcr = icrs - 1
          xwrk1 = xwrkt(idcr - 1)
          Do
            If (xwrk >= xwrk1) Exit
            xwrkt(idcr) = xwrk1
            idcr = idcr - 1
            xwrk1 = xwrkt(idcr - 1)
          End Do
          xwrkt(idcr) = xwrk
        end if
      End Do
    End Do
    !
    !  Add-up alternatively + and - HUGE values to make the number of data
    !  an exact multiple of 7.
    !
    ideb = 7 * (ndon / 7)
    ntri = ndon
    If (ideb < ndon) Then
      !
      xwrk1 = xhuge
      Do icrs = ideb + 1, ideb + 7
        If (icrs <= ndon) Then
          xwrkt(icrs) = xdont(icrs)
        Else
          If (ne(xwrk1, xhuge)) nmed = nmed + 1
          xwrkt(icrs) = xwrk1
          xwrk1 = - xwrk1
        end if
      End Do
      !
      Do icrs = ideb + 2, ideb + 7
        xwrk = xwrkt(icrs)
        Do idcr = icrs - 1, ideb + 1, - 1
          If (xwrk >= xwrkt(idcr)) Exit
          xwrkt(idcr + 1) = xwrkt(idcr)
        End Do
        xwrkt(idcr + 1) = xwrk
      End Do
      !
      ntri = ideb + 7
    End If
    !
    !  Make the set of the indices of median values of each sorted subset
    !
    idon1 = 0
    Do idon = 1, ntri, 7
      idon1 = idon1 + 1
      imedt(idon1) = idon + 3
    End Do
    !
    !  Find XMED7, the median of the medians
    !
    xmed7 = d_valmed(xwrkt(imedt))
    !
    !  Count how many values are not higher than (and how many equal to) XMED7
    !  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
    !  subsets where the median is lower than the median of medians. For similar
    !  reasons, we also have at least 2N/7 values not lower than XMED7. At the
    !  same time, we find in each subset the index of the last value < XMED7,
    !  and that of the first > XMED7. These indices will be used to restrict the
    !  search for the median as the Kth element in the subset (> or <) where
    !  we know it to be.
    !
    idon1 = 1
    nleq = 0
    nequ = 0
    Do idon = 1, ntri, 7
      imed = idon + 3
      If (xwrkt(imed) > xmed7) Then
        imed = imed - 2
        If (xwrkt(imed) > xmed7) Then
          imed = imed - 1
        Else If (xwrkt(imed) < xmed7) Then
          imed = imed + 1
        end if
      Else If (xwrkt(imed) < xmed7) Then
        imed = imed + 2
        If (xwrkt(imed) > xmed7) Then
          imed = imed - 1
        Else If (xwrkt(imed) < xmed7) Then
          imed = imed + 1
        end if
      end if
      If (xwrkt(imed) > xmed7) Then
        nleq = nleq + imed - idon
        iendt(idon1) = imed - 1
        istrt(idon1) = imed
      Else If (xwrkt(imed) < xmed7) Then
        nleq = nleq + imed - idon + 1
        iendt(idon1) = imed
        istrt(idon1) = imed + 1
      Else                    !       If (XWRKT (IMED) == XMED7)
        nleq = nleq + imed - idon + 1
        nequ = nequ + 1
        iendt(idon1) = imed - 1
        Do imed1 = imed - 1, idon, -1
          If (eq(xwrkt(imed1), xmed7)) Then
            nequ = nequ + 1
            iendt(idon1) = imed1 - 1
          Else
            Exit
          End If
        End Do
        istrt(idon1) = imed + 1
        Do imed1 = imed + 1, idon + 6
          If (eq(xwrkt(imed1), xmed7)) Then
            nequ = nequ + 1
            nleq = nleq + 1
            istrt(idon1) = imed1 + 1
          Else
            Exit
          End If
        End Do
      end if
      idon1 = idon1 + 1
    End Do
    !
    !  Carry out a partial insertion sort to find the Kth smallest of the
    !  large values, or the Kth largest of the small values, according to
    !  what is needed.
    !
    If (nleq - nequ + 1 <= nmed) Then
      If (nleq < nmed) Then   !      Not enough low values
        xwrk1 = xhuge
        nord = nmed - nleq
        idon1 = 0
        icrs1 = 1
        icrs2 = 0
        idcr = 0
        Do idon = 1, ntri, 7
          idon1 = idon1 + 1
          If (icrs2 < nord) Then
            Do icrs = istrt(idon1), idon + 6
              If (xwrkt(icrs) < xwrk1) Then
                xwrk = xwrkt(icrs)
                Do idcr = icrs1 - 1, 1, - 1
                  If (xwrk >= xwrkt(idcr)) Exit
                  xwrkt(idcr + 1) = xwrkt(idcr)
                End Do
                xwrkt(idcr + 1) = xwrk
                xwrk1 = xwrkt(icrs1)
              Else
                If (icrs2 < nord) Then
                  xwrkt(icrs1) = xwrkt(icrs)
                  xwrk1 = xwrkt(icrs1)
                end if
              End If
              icrs1 = min(nord, icrs1 + 1)
              icrs2 = min(nord, icrs2 + 1)
            End Do
          Else
            Do icrs = istrt(idon1), idon + 6
              If (xwrkt(icrs) >= xwrk1) Exit
              xwrk = xwrkt(icrs)
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk >= xwrkt(idcr)) Exit
                xwrkt(idcr + 1) = xwrkt(idcr)
              End Do
              xwrkt(idcr + 1) = xwrk
              xwrk1 = xwrkt(icrs1)
            End Do
          End If
        End Do
        res_med = xwrk1
        Return
      Else
        res_med = xmed7
        Return
      End If
    Else                       !      If (NLEQ > NMED)
      !                                          Not enough high values
      xwrk1 = -xhuge
      nord = nleq - nequ - nmed + 1
      idon1 = 0
      icrs1 = 1
      icrs2 = 0
      Do idon = 1, ntri, 7
        idon1 = idon1 + 1
        If (icrs2 < nord) Then
          !
          Do icrs = idon, iendt(idon1)
            If (xwrkt(icrs) > xwrk1) Then
              xwrk = xwrkt(icrs)
              idcr = icrs1 - 1
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk <= xwrkt(idcr)) Exit
                xwrkt(idcr + 1) = xwrkt(idcr)
              End Do
              xwrkt(idcr + 1) = xwrk
              xwrk1 = xwrkt(icrs1)
            Else
              If (icrs2 < nord) Then
                xwrkt(icrs1) = xwrkt(icrs)
                xwrk1 = xwrkt(icrs1)
              End If
            End If
            icrs1 = min(nord, icrs1 + 1)
            icrs2 = min(nord, icrs2 + 1)
          End Do
        Else
          Do icrs = iendt(idon1), idon, -1
            If (xwrkt(icrs) > xwrk1) Then
              xwrk = xwrkt(icrs)
              idcr = icrs1 - 1
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk <= xwrkt(idcr)) Exit
                xwrkt(idcr + 1) = xwrkt(idcr)
              End Do
              xwrkt(idcr + 1) = xwrk
              xwrk1 = xwrkt(icrs1)
            Else
              Exit
            End If
          End Do
        end if
      End Do
      !
      res_med = xwrk1
      Return
    End If
    !
  End Function d_valmed
 
  Recursive Function r_valmed (XDONT) Result (res_med)
    !  Finds the median of XDONT using the recursive procedure
    !  described in Knuth, The Art of Computer Programming,
    !  vol. 3, 5.3.3 - This procedure is linear in time, and
    !  does not require to be able to interpolate in the
    !  set as the one used in INDNTH. It also has better worst
    !  case behavior than INDNTH, but is about 30% slower in
    !  average for random uniformly distributed values.
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Real(kind = sp) :: res_med
    ! __________________________________________________________
    Real(kind = sp), Parameter :: xhuge = huge(xdont)
    Real(kind = sp), Dimension (SIZE(XDONT) + 6) :: xwrkt
    Real(kind = sp) :: xwrk, xwrk1, xmed7
    !
    Integer(kind = i4), Dimension ((SIZE(XDONT) + 6) / 7) :: ISTRT, IENDT, IMEDT
    Integer(kind = i4) :: NDON, NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
    Integer(kind = i4) :: IDEB, IWRK, IDCR, ICRS, ICRS1, ICRS2, IMED1
    !
    ndon = SIZE (xdont)
    nmed = (ndon + 1) / 2
    !      write(unit=*,fmt=*) NMED, NDON
    !
    !  If the number of values is small, then use insertion sort
    !
    If (ndon < 35) Then
      !
      !  Bring minimum to first location to save test in decreasing loop
      !
      idcr = ndon
      If (xdont(1) < xdont(ndon)) Then
        xwrk = xdont(1)
        xwrkt(idcr) = xdont(idcr)
      Else
        xwrk = xdont(idcr)
        xwrkt(idcr) = xdont(1)
      end if
      Do iwrk = 1, ndon - 2
        idcr = idcr - 1
        xwrk1 = xdont(idcr)
        If (xwrk1 < xwrk) Then
          xwrkt(idcr) = xwrk
          xwrk = xwrk1
        Else
          xwrkt(idcr) = xwrk1
        end if
      End Do
      xwrkt(1) = xwrk
      !
      ! Sort the first half, until we have NMED sorted values
      !
      Do icrs = 3, nmed
        xwrk = xwrkt(icrs)
        idcr = icrs - 1
        Do
          If (xwrk >= xwrkt(idcr)) Exit
          xwrkt(idcr + 1) = xwrkt(idcr)
          idcr = idcr - 1
        End Do
        xwrkt(idcr + 1) = xwrk
      End Do
      !
      !  Insert any value less than the current median in the first half
      !
      Do icrs = nmed + 1, ndon
        xwrk = xwrkt(icrs)
        If (xwrk < xwrkt(nmed)) Then
          idcr = nmed - 1
          Do
            If (xwrk >= xwrkt(idcr)) Exit
            xwrkt(idcr + 1) = xwrkt(idcr)
            idcr = idcr - 1
          End Do
          xwrkt(idcr + 1) = xwrk
        End If
      End Do
      res_med = xwrkt(nmed)
      Return
    End If
    !
    !  Make sorted subsets of 7 elements
    !  This is done by a variant of insertion sort where a first
    !  pass is used to bring the smallest element to the first position
    !  decreasing disorder at the same time, so that we may remove
    !  remove the loop test in the insertion loop.
    !
    DO ideb = 1, ndon - 6, 7
      idcr = ideb + 6
      If (xdont(ideb) < xdont(idcr)) Then
        xwrk = xdont(ideb)
        xwrkt(idcr) = xdont(idcr)
      Else
        xwrk = xdont(idcr)
        xwrkt(idcr) = xdont(ideb)
      end if
      Do iwrk = 1, 5
        idcr = idcr - 1
        xwrk1 = xdont(idcr)
        If (xwrk1 < xwrk) Then
          xwrkt(idcr) = xwrk
          xwrk = xwrk1
        Else
          xwrkt(idcr) = xwrk1
        end if
      End Do
      xwrkt(ideb) = xwrk
      Do icrs = ideb + 2, ideb + 6
        xwrk = xwrkt(icrs)
        If (xwrk < xwrkt(icrs - 1)) Then
          xwrkt(icrs) = xwrkt(icrs - 1)
          idcr = icrs - 1
          xwrk1 = xwrkt(idcr - 1)
          Do
            If (xwrk >= xwrk1) Exit
            xwrkt(idcr) = xwrk1
            idcr = idcr - 1
            xwrk1 = xwrkt(idcr - 1)
          End Do
          xwrkt(idcr) = xwrk
        end if
      End Do
    End Do
    !
    !  Add-up alternatively + and - HUGE values to make the number of data
    !  an exact multiple of 7.
    !
    ideb = 7 * (ndon / 7)
    ntri = ndon
    If (ideb < ndon) Then
      !
      xwrk1 = xhuge
      Do icrs = ideb + 1, ideb + 7
        If (icrs <= ndon) Then
          xwrkt(icrs) = xdont(icrs)
        Else
          If (ne(xwrk1, xhuge)) nmed = nmed + 1
          xwrkt(icrs) = xwrk1
          xwrk1 = - xwrk1
        end if
      End Do
      !
      Do icrs = ideb + 2, ideb + 7
        xwrk = xwrkt(icrs)
        Do idcr = icrs - 1, ideb + 1, - 1
          If (xwrk >= xwrkt(idcr)) Exit
          xwrkt(idcr + 1) = xwrkt(idcr)
        End Do
        xwrkt(idcr + 1) = xwrk
      End Do
      !
      ntri = ideb + 7
    End If
    !
    !  Make the set of the indices of median values of each sorted subset
    !
    idon1 = 0
    Do idon = 1, ntri, 7
      idon1 = idon1 + 1
      imedt(idon1) = idon + 3
    End Do
    !
    !  Find XMED7, the median of the medians
    !
    xmed7 = r_valmed(xwrkt(imedt))
    !
    !  Count how many values are not higher than (and how many equal to) XMED7
    !  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
    !  subsets where the median is lower than the median of medians. For similar
    !  reasons, we also have at least 2N/7 values not lower than XMED7. At the
    !  same time, we find in each subset the index of the last value < XMED7,
    !  and that of the first > XMED7. These indices will be used to restrict the
    !  search for the median as the Kth element in the subset (> or <) where
    !  we know it to be.
    !
    idon1 = 1
    nleq = 0
    nequ = 0
    Do idon = 1, ntri, 7
      imed = idon + 3
      If (xwrkt(imed) > xmed7) Then
        imed = imed - 2
        If (xwrkt(imed) > xmed7) Then
          imed = imed - 1
        Else If (xwrkt(imed) < xmed7) Then
          imed = imed + 1
        end if
      Else If (xwrkt(imed) < xmed7) Then
        imed = imed + 2
        If (xwrkt(imed) > xmed7) Then
          imed = imed - 1
        Else If (xwrkt(imed) < xmed7) Then
          imed = imed + 1
        end if
      end if
      If (xwrkt(imed) > xmed7) Then
        nleq = nleq + imed - idon
        iendt(idon1) = imed - 1
        istrt(idon1) = imed
      Else If (xwrkt(imed) < xmed7) Then
        nleq = nleq + imed - idon + 1
        iendt(idon1) = imed
        istrt(idon1) = imed + 1
      Else                    !       If (XWRKT (IMED) == XMED7)
        nleq = nleq + imed - idon + 1
        nequ = nequ + 1
        iendt(idon1) = imed - 1
        Do imed1 = imed - 1, idon, -1
          If (eq(xwrkt(imed1), xmed7)) Then
            nequ = nequ + 1
            iendt(idon1) = imed1 - 1
          Else
            Exit
          End If
        End Do
        istrt(idon1) = imed + 1
        Do imed1 = imed + 1, idon + 6
          If (eq(xwrkt(imed1), xmed7)) Then
            nequ = nequ + 1
            nleq = nleq + 1
            istrt(idon1) = imed1 + 1
          Else
            Exit
          End If
        End Do
      end if
      idon1 = idon1 + 1
    End Do
    !
    !  Carry out a partial insertion sort to find the Kth smallest of the
    !  large values, or the Kth largest of the small values, according to
    !  what is needed.
    !
    If (nleq - nequ + 1 <= nmed) Then
      If (nleq < nmed) Then   !      Not enough low values
        xwrk1 = xhuge
        nord = nmed - nleq
        idon1 = 0
        icrs1 = 1
        icrs2 = 0
        idcr = 0
        Do idon = 1, ntri, 7
          idon1 = idon1 + 1
          If (icrs2 < nord) Then
            Do icrs = istrt(idon1), idon + 6
              If (xwrkt(icrs) < xwrk1) Then
                xwrk = xwrkt(icrs)
                Do idcr = icrs1 - 1, 1, - 1
                  If (xwrk >= xwrkt(idcr)) Exit
                  xwrkt(idcr + 1) = xwrkt(idcr)
                End Do
                xwrkt(idcr + 1) = xwrk
                xwrk1 = xwrkt(icrs1)
              Else
                If (icrs2 < nord) Then
                  xwrkt(icrs1) = xwrkt(icrs)
                  xwrk1 = xwrkt(icrs1)
                end if
              End If
              icrs1 = min(nord, icrs1 + 1)
              icrs2 = min(nord, icrs2 + 1)
            End Do
          Else
            Do icrs = istrt(idon1), idon + 6
              If (xwrkt(icrs) >= xwrk1) Exit
              xwrk = xwrkt(icrs)
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk >= xwrkt(idcr)) Exit
                xwrkt(idcr + 1) = xwrkt(idcr)
              End Do
              xwrkt(idcr + 1) = xwrk
              xwrk1 = xwrkt(icrs1)
            End Do
          End If
        End Do
        res_med = xwrk1
        Return
      Else
        res_med = xmed7
        Return
      End If
    Else                       !      If (NLEQ > NMED)
      !                                          Not enough high values
      xwrk1 = -xhuge
      nord = nleq - nequ - nmed + 1
      idon1 = 0
      icrs1 = 1
      icrs2 = 0
      Do idon = 1, ntri, 7
        idon1 = idon1 + 1
        If (icrs2 < nord) Then
          !
          Do icrs = idon, iendt(idon1)
            If (xwrkt(icrs) > xwrk1) Then
              xwrk = xwrkt(icrs)
              idcr = icrs1 - 1
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk <= xwrkt(idcr)) Exit
                xwrkt(idcr + 1) = xwrkt(idcr)
              End Do
              xwrkt(idcr + 1) = xwrk
              xwrk1 = xwrkt(icrs1)
            Else
              If (icrs2 < nord) Then
                xwrkt(icrs1) = xwrkt(icrs)
                xwrk1 = xwrkt(icrs1)
              End If
            End If
            icrs1 = min(nord, icrs1 + 1)
            icrs2 = min(nord, icrs2 + 1)
          End Do
        Else
          Do icrs = iendt(idon1), idon, -1
            If (xwrkt(icrs) > xwrk1) Then
              xwrk = xwrkt(icrs)
              idcr = icrs1 - 1
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk <= xwrkt(idcr)) Exit
                xwrkt(idcr + 1) = xwrkt(idcr)
              End Do
              xwrkt(idcr + 1) = xwrk
              xwrk1 = xwrkt(icrs1)
            Else
              Exit
            End If
          End Do
        end if
      End Do
      !
      res_med = xwrk1
      Return
    End If
    !
  End Function r_valmed
 
  Recursive Function i_valmed (XDONT) Result (res_med)
    !  Finds the median of XDONT using the recursive procedure
    !  described in Knuth, The Art of Computer Programming,
    !  vol. 3, 5.3.3 - This procedure is linear in time, and
    !  does not require to be able to interpolate in the
    !  set as the one used in INDNTH. It also has better worst
    !  case behavior than INDNTH, but is about 30% slower in
    !  average for random uniformly distributed values.
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4) :: res_med
    ! __________________________________________________________
    Integer(kind = i4), Parameter :: XHUGE = huge (xdont)
    Integer(kind = i4), Dimension (SIZE(XDONT) + 6) :: XWRKT
    Integer(kind = i4) :: XWRK, XWRK1, XMED7
    !
    Integer(kind = i4), Dimension ((SIZE(XDONT) + 6) / 7) :: ISTRT, IENDT, IMEDT
    Integer(kind = i4) :: NDON, NTRI, NMED, NORD, NEQU, NLEQ, IMED, IDON, IDON1
    Integer(kind = i4) :: IDEB, IWRK, IDCR, ICRS, ICRS1, ICRS2, IMED1
    !
    ndon = SIZE (xdont)
    nmed = (ndon + 1) / 2
    !      write(unit=*,fmt=*) NMED, NDON
    !
    !  If the number of values is small, then use insertion sort
    !
    If (ndon < 35) Then
      !
      !  Bring minimum to first location to save test in decreasing loop
      !
      idcr = ndon
      If (xdont(1) < xdont(ndon)) Then
        xwrk = xdont(1)
        xwrkt(idcr) = xdont(idcr)
      Else
        xwrk = xdont(idcr)
        xwrkt(idcr) = xdont(1)
      end if
      Do iwrk = 1, ndon - 2
        idcr = idcr - 1
        xwrk1 = xdont(idcr)
        If (xwrk1 < xwrk) Then
          xwrkt(idcr) = xwrk
          xwrk = xwrk1
        Else
          xwrkt(idcr) = xwrk1
        end if
      End Do
      xwrkt(1) = xwrk
      !
      ! Sort the first half, until we have NMED sorted values
      !
      Do icrs = 3, nmed
        xwrk = xwrkt(icrs)
        idcr = icrs - 1
        Do
          If (xwrk >= xwrkt(idcr)) Exit
          xwrkt(idcr + 1) = xwrkt(idcr)
          idcr = idcr - 1
        End Do
        xwrkt(idcr + 1) = xwrk
      End Do
      !
      !  Insert any value less than the current median in the first half
      !
      Do icrs = nmed + 1, ndon
        xwrk = xwrkt(icrs)
        If (xwrk < xwrkt(nmed)) Then
          idcr = nmed - 1
          Do
            If (xwrk >= xwrkt(idcr)) Exit
            xwrkt(idcr + 1) = xwrkt(idcr)
            idcr = idcr - 1
          End Do
          xwrkt(idcr + 1) = xwrk
        End If
      End Do
      res_med = xwrkt(nmed)
      Return
    End If
    !
    !  Make sorted subsets of 7 elements
    !  This is done by a variant of insertion sort where a first
    !  pass is used to bring the smallest element to the first position
    !  decreasing disorder at the same time, so that we may remove
    !  remove the loop test in the insertion loop.
    !
    DO ideb = 1, ndon - 6, 7
      idcr = ideb + 6
      If (xdont(ideb) < xdont(idcr)) Then
        xwrk = xdont(ideb)
        xwrkt(idcr) = xdont(idcr)
      Else
        xwrk = xdont(idcr)
        xwrkt(idcr) = xdont(ideb)
      end if
      Do iwrk = 1, 5
        idcr = idcr - 1
        xwrk1 = xdont(idcr)
        If (xwrk1 < xwrk) Then
          xwrkt(idcr) = xwrk
          xwrk = xwrk1
        Else
          xwrkt(idcr) = xwrk1
        end if
      End Do
      xwrkt(ideb) = xwrk
      Do icrs = ideb + 2, ideb + 6
        xwrk = xwrkt(icrs)
        If (xwrk < xwrkt(icrs - 1)) Then
          xwrkt(icrs) = xwrkt(icrs - 1)
          idcr = icrs - 1
          xwrk1 = xwrkt(idcr - 1)
          Do
            If (xwrk >= xwrk1) Exit
            xwrkt(idcr) = xwrk1
            idcr = idcr - 1
            xwrk1 = xwrkt(idcr - 1)
          End Do
          xwrkt(idcr) = xwrk
        end if
      End Do
    End Do
    !
    !  Add-up alternatively + and - HUGE values to make the number of data
    !  an exact multiple of 7.
    !
    ideb = 7 * (ndon / 7)
    ntri = ndon
    If (ideb < ndon) Then
      !
      xwrk1 = xhuge
      Do icrs = ideb + 1, ideb + 7
        If (icrs <= ndon) Then
          xwrkt(icrs) = xdont(icrs)
        Else
          If (xwrk1 /= xhuge) nmed = nmed + 1
          xwrkt(icrs) = xwrk1
          xwrk1 = - xwrk1
        end if
      End Do
      !
      Do icrs = ideb + 2, ideb + 7
        xwrk = xwrkt(icrs)
        Do idcr = icrs - 1, ideb + 1, - 1
          If (xwrk >= xwrkt(idcr)) Exit
          xwrkt(idcr + 1) = xwrkt(idcr)
        End Do
        xwrkt(idcr + 1) = xwrk
      End Do
      !
      ntri = ideb + 7
    End If
    !
    !  Make the set of the indices of median values of each sorted subset
    !
    idon1 = 0
    Do idon = 1, ntri, 7
      idon1 = idon1 + 1
      imedt(idon1) = idon + 3
    End Do
    !
    !  Find XMED7, the median of the medians
    !
    xmed7 = i_valmed(xwrkt(imedt))
    !
    !  Count how many values are not higher than (and how many equal to) XMED7
    !  This number is at least 4 * 1/2 * (N/7) : 4 values in each of the
    !  subsets where the median is lower than the median of medians. For similar
    !  reasons, we also have at least 2N/7 values not lower than XMED7. At the
    !  same time, we find in each subset the index of the last value < XMED7,
    !  and that of the first > XMED7. These indices will be used to restrict the
    !  search for the median as the Kth element in the subset (> or <) where
    !  we know it to be.
    !
    idon1 = 1
    nleq = 0
    nequ = 0
    Do idon = 1, ntri, 7
      imed = idon + 3
      If (xwrkt(imed) > xmed7) Then
        imed = imed - 2
        If (xwrkt(imed) > xmed7) Then
          imed = imed - 1
        Else If (xwrkt(imed) < xmed7) Then
          imed = imed + 1
        end if
      Else If (xwrkt(imed) < xmed7) Then
        imed = imed + 2
        If (xwrkt(imed) > xmed7) Then
          imed = imed - 1
        Else If (xwrkt(imed) < xmed7) Then
          imed = imed + 1
        end if
      end if
      If (xwrkt(imed) > xmed7) Then
        nleq = nleq + imed - idon
        iendt(idon1) = imed - 1
        istrt(idon1) = imed
      Else If (xwrkt(imed) < xmed7) Then
        nleq = nleq + imed - idon + 1
        iendt(idon1) = imed
        istrt(idon1) = imed + 1
      Else                    !       If (XWRKT (IMED) == XMED7)
        nleq = nleq + imed - idon + 1
        nequ = nequ + 1
        iendt(idon1) = imed - 1
        Do imed1 = imed - 1, idon, -1
          If (xwrkt(imed1) == xmed7) Then
            nequ = nequ + 1
            iendt(idon1) = imed1 - 1
          Else
            Exit
          End If
        End Do
        istrt(idon1) = imed + 1
        Do imed1 = imed + 1, idon + 6
          If (xwrkt(imed1) == xmed7) Then
            nequ = nequ + 1
            nleq = nleq + 1
            istrt(idon1) = imed1 + 1
          Else
            Exit
          End If
        End Do
      end if
      idon1 = idon1 + 1
    End Do
    !
    !  Carry out a partial insertion sort to find the Kth smallest of the
    !  large values, or the Kth largest of the small values, according to
    !  what is needed.
    !
    If (nleq - nequ + 1 <= nmed) Then
      If (nleq < nmed) Then   !      Not enough low values
        xwrk1 = xhuge
        nord = nmed - nleq
        idon1 = 0
        icrs1 = 1
        icrs2 = 0
        idcr = 0
        Do idon = 1, ntri, 7
          idon1 = idon1 + 1
          If (icrs2 < nord) Then
            Do icrs = istrt(idon1), idon + 6
              If (xwrkt(icrs) < xwrk1) Then
                xwrk = xwrkt(icrs)
                Do idcr = icrs1 - 1, 1, - 1
                  If (xwrk >= xwrkt(idcr)) Exit
                  xwrkt(idcr + 1) = xwrkt(idcr)
                End Do
                xwrkt(idcr + 1) = xwrk
                xwrk1 = xwrkt(icrs1)
              Else
                If (icrs2 < nord) Then
                  xwrkt(icrs1) = xwrkt(icrs)
                  xwrk1 = xwrkt(icrs1)
                end if
              End If
              icrs1 = min(nord, icrs1 + 1)
              icrs2 = min(nord, icrs2 + 1)
            End Do
          Else
            Do icrs = istrt(idon1), idon + 6
              If (xwrkt(icrs) >= xwrk1) Exit
              xwrk = xwrkt(icrs)
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk >= xwrkt(idcr)) Exit
                xwrkt(idcr + 1) = xwrkt(idcr)
              End Do
              xwrkt(idcr + 1) = xwrk
              xwrk1 = xwrkt(icrs1)
            End Do
          End If
        End Do
        res_med = xwrk1
        Return
      Else
        res_med = xmed7
        Return
      End If
    Else                       !      If (NLEQ > NMED)
      !                                          Not enough high values
      xwrk1 = -xhuge
      nord = nleq - nequ - nmed + 1
      idon1 = 0
      icrs1 = 1
      icrs2 = 0
      Do idon = 1, ntri, 7
        idon1 = idon1 + 1
        If (icrs2 < nord) Then
          !
          Do icrs = idon, iendt(idon1)
            If (xwrkt(icrs) > xwrk1) Then
              xwrk = xwrkt(icrs)
              idcr = icrs1 - 1
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk <= xwrkt(idcr)) Exit
                xwrkt(idcr + 1) = xwrkt(idcr)
              End Do
              xwrkt(idcr + 1) = xwrk
              xwrk1 = xwrkt(icrs1)
            Else
              If (icrs2 < nord) Then
                xwrkt(icrs1) = xwrkt(icrs)
                xwrk1 = xwrkt(icrs1)
              End If
            End If
            icrs1 = min(nord, icrs1 + 1)
            icrs2 = min(nord, icrs2 + 1)
          End Do
        Else
          Do icrs = iendt(idon1), idon, -1
            If (xwrkt(icrs) > xwrk1) Then
              xwrk = xwrkt(icrs)
              idcr = icrs1 - 1
              Do idcr = icrs1 - 1, 1, - 1
                If (xwrk <= xwrkt(idcr)) Exit
                xwrkt(idcr + 1) = xwrkt(idcr)
              End Do
              xwrkt(idcr + 1) = xwrk
              xwrk1 = xwrkt(icrs1)
            Else
              Exit
            End If
          End Do
        end if
      End Do
      !
      res_med = xwrk1
      Return
    End If
    !
  End Function i_valmed
 
  Function d_valnth (XDONT, NORD) Result (valnth)
    !  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then finds the maximum of this set.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    real(Kind = dp), Dimension (:), Intent (In) :: xdont
    real(Kind = dp) :: valnth
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    real(Kind = dp), Dimension (SIZE(XDONT)) :: xlowt, xhigt
    real(Kind = dp) :: xpiv, xwrk, xwrk1, xwrk2, xwrk3, xmin, xmax
    !
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG
    Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
    !
    ndon = SIZE (xdont)
    inth = max(min(nord, ndon), 1)
    !
    !    First loop is used to fill-in XLOWT, XHIGT at the same time
    !
    If (ndon < 2) Then
      If (inth == 1) valnth = xdont(1)
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      xlowt(1) = xdont(2)
      xhigt(1) = xdont(1)
    Else
      xlowt(1) = xdont(1)
      xhigt(1) = xdont(2)
    End If
    !
    If (ndon < 3) Then
      If (inth == 1) valnth = xlowt(1)
      If (inth == 2) valnth = xhigt(1)
      Return
    End If
    !
    If (xdont(3) < xhigt(1)) Then
      xhigt(2) = xhigt(1)
      If (xdont(3) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(3)
      Else
        xhigt(1) = xdont(3)
      End If
    Else
      xhigt(2) = xdont(3)
    End If
    !
    If (ndon < 4) Then
      If (inth == 1) Then
        valnth = xlowt(1)
      Else
        valnth = xhigt(inth - 1)
      End If
      Return
    End If
    !
    If (xdont(ndon) < xhigt(1)) Then
      xhigt(3) = xhigt(2)
      xhigt(2) = xhigt(1)
      If (xdont(ndon) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(ndon)
      Else
        xhigt(1) = xdont(ndon)
      End If
    Else
      xhigt(3) = xdont(ndon)
    End If
    !
    If (ndon < 5) Then
      If (inth == 1) Then
        valnth = xlowt(1)
      Else
        valnth = xhigt(inth - 1)
      End If
      Return
    End If
    !
 
    jlow = 1
    jhig = 3
    xpiv = xlowt(1) + real(2 * inth, dp) / real(ndon + inth, dp) * (xhigt(3) - xlowt(1))
    If (xpiv >= xhigt(1)) Then
      xpiv = xlowt(1) + real(2 * inth, dp) / real(ndon + inth, dp) * &
              (xhigt(2) - xlowt(1))
      If (xpiv >= xhigt(1)) &
              xpiv = xlowt(1) + real(2 * inth, dp) / real(ndon + inth, dp) * &
                      (xhigt(1) - xlowt(1))
    End If
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the XHIGT array as soon as we have more
    !  than enough values in XLOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to INTH
        !
        If (inth > jlow) Then
          xmin = xhigt(1)
          ihig = 1
          Do icrs = 2, jhig
            If (xhigt(icrs) < xmin) Then
              xmin = xhigt(icrs)
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          xlowt(jlow) = xhigt(ihig)
          xhigt(ihig) = xhigt(jhig)
          jhig = jhig - 1
        Else
 
          xmax = xlowt(jlow)
          jlow = jlow - 1
          Do icrs = 1, jlow
            If (xlowt(icrs) > xmax) Then
              xwrk = xmax
              xmax = xlowt(icrs)
              xlowt(icrs) = xwrk
            End If
          End Do
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to INTH.
      !
      Select Case (inth - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        inth = inth - jlow
        jlow = 0
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (unit=*,fmt=*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xhigt(1) <= xhigt(2)) Then
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
          Else
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(3)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(3) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, inth
            jhig = jhig + 1
            xlowt(icrs) = xhigt(jhig)
          End Do
          jlow = inth
          Exit
          !
        Case (4 :)
          !
          !
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(ifin)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(ifin) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          !
          xwrk1 = xhigt(1)
          jlow = jlow + 1
          xlowt(jlow) = xwrk1
          xpiv = xwrk1 + 0.5 * (xhigt(ifin) - xwrk1)
          !
          !  One takes values <= pivot to XLOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
              If (jlow >= inth) Exit
            Else
              jhig = jhig + 1
              xhigt(jhig) = xhigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xhigt(1)
        ihig = 1
        Do icrs = 2, jhig
          If (xhigt(icrs) < xmin) Then
            xmin = xhigt(icrs)
            ihig = icrs
          End If
        End Do
        !
        valnth = xhigt(ihig)
        Return
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        xhigt(1) = xlowt(1)
        ilow = 1 + inth - jlow
        Do icrs = 2, inth
          xwrk = xlowt(icrs)
          Do idcr = icrs - 1, max(1, ilow), - 1
            If (xwrk < xhigt(idcr)) Then
              xhigt(idcr + 1) = xhigt(idcr)
            Else
              Exit
            End If
          End Do
          xhigt(idcr + 1) = xwrk
          ilow = ilow + 1
        End Do
        !
        xwrk1 = xhigt(inth)
        ilow = 2 * inth - jlow
        Do icrs = inth + 1, jlow
          If (xlowt(icrs) < xwrk1) Then
            xwrk = xlowt(icrs)
            Do idcr = inth - 1, max(1, ilow), - 1
              If (xwrk >= xhigt(idcr)) Exit
              xhigt(idcr + 1) = xhigt(idcr)
            End Do
            xhigt(idcr + 1) = xlowt(icrs)
            xwrk1 = xhigt(inth)
          End If
          ilow = ilow + 1
        End Do
        !
        valnth = xhigt(inth)
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
 
        imil = (jlow + 1) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xlowt(imil) < xlowt(1)) Then
          xwrk = xlowt(1)
          xlowt(1) = xlowt(imil)
          xlowt(imil) = xwrk
        End If
        If (xlowt(imil) > xlowt(ifin)) Then
          xwrk = xlowt(ifin)
          xlowt(ifin) = xlowt(imil)
          xlowt(imil) = xwrk
          If (xlowt(imil) < xlowt(1)) Then
            xwrk = xlowt(1)
            xlowt(1) = xlowt(imil)
            xlowt(imil) = xwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xlowt(1) + real(inth, dp) / real(jlow + inth, dp) * &
                (xlowt(ifin) - xlowt(1))
 
        !
        !  One takes values > XPIV to XHIGT
        !
        jhig = 0
        jlow = 0
        !
        If (xlowt(ifin) > xpiv) Then
          icrs = 0
          Do
            icrs = icrs + 1
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xlowt(icrs) <= xpiv) Then
                jlow = jlow + 1
                xlowt(jlow) = xlowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = 1, ifin
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xlowt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to find maximum of the 1:INTH set
    !
    valnth = maxval(xlowt(1 : inth))
    Return
    !
    !
  End Function d_valnth
 
  Function r_valnth (XDONT, NORD) Result (valnth)
    !  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then finds the maximum of this set.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! _________________________________________________________
    Real(kind = sp), Dimension (:), Intent (In) :: xdont
    Real(kind = sp) :: valnth
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Real(kind = sp), Dimension (SIZE(XDONT)) :: xlowt, xhigt
    Real(kind = sp) :: xpiv, xwrk, xwrk1, xwrk2, xwrk3, xmin, xmax
    !
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG
    Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
    !
    ndon = SIZE (xdont)
    inth = max(min(nord, ndon), 1)
    !
    !    First loop is used to fill-in XLOWT, XHIGT at the same time
    !
    If (ndon < 2) Then
      If (inth == 1) valnth = xdont(1)
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      xlowt(1) = xdont(2)
      xhigt(1) = xdont(1)
    Else
      xlowt(1) = xdont(1)
      xhigt(1) = xdont(2)
    End If
    !
    If (ndon < 3) Then
      If (inth == 1) valnth = xlowt(1)
      If (inth == 2) valnth = xhigt(1)
      Return
    End If
    !
    If (xdont(3) < xhigt(1)) Then
      xhigt(2) = xhigt(1)
      If (xdont(3) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(3)
      Else
        xhigt(1) = xdont(3)
      End If
    Else
      xhigt(2) = xdont(3)
    End If
    !
    If (ndon < 4) Then
      If (inth == 1) Then
        valnth = xlowt(1)
      Else
        valnth = xhigt(inth - 1)
      End If
      Return
    End If
    !
    If (xdont(ndon) < xhigt(1)) Then
      xhigt(3) = xhigt(2)
      xhigt(2) = xhigt(1)
      If (xdont(ndon) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(ndon)
      Else
        xhigt(1) = xdont(ndon)
      End If
    Else
      xhigt(3) = xdont(ndon)
    End If
    !
    If (ndon < 5) Then
      If (inth == 1) Then
        valnth = xlowt(1)
      Else
        valnth = xhigt(inth - 1)
      End If
      Return
    End If
    !
 
    jlow = 1
    jhig = 3
    xpiv = xlowt(1) + real(2 * inth, sp) / real(ndon + inth, sp) * (xhigt(3) - xlowt(1))
    If (xpiv >= xhigt(1)) Then
      xpiv = xlowt(1) + real(2 * inth, sp) / real(ndon + inth, sp) * &
              (xhigt(2) - xlowt(1))
      If (xpiv >= xhigt(1)) &
              xpiv = xlowt(1) + real(2 * inth, sp) / real(ndon + inth, sp) * &
                      (xhigt(1) - xlowt(1))
    End If
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the XHIGT array as soon as we have more
    !  than enough values in XLOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to INTH
        !
        If (inth > jlow) Then
          xmin = xhigt(1)
          ihig = 1
          Do icrs = 2, jhig
            If (xhigt(icrs) < xmin) Then
              xmin = xhigt(icrs)
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          xlowt(jlow) = xhigt(ihig)
          xhigt(ihig) = xhigt(jhig)
          jhig = jhig - 1
        Else
 
          xmax = xlowt(jlow)
          jlow = jlow - 1
          Do icrs = 1, jlow
            If (xlowt(icrs) > xmax) Then
              xwrk = xmax
              xmax = xlowt(icrs)
              xlowt(icrs) = xwrk
            End If
          End Do
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to INTH.
      !
      Select Case (inth - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        inth = inth - jlow
        jlow = 0
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (unit=*,fmt=*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xhigt(1) <= xhigt(2)) Then
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
          Else
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(3)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(3) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, inth
            jhig = jhig + 1
            xlowt(icrs) = xhigt(jhig)
          End Do
          jlow = inth
          Exit
          !
        Case (4 :)
          !
          !
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(ifin)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(ifin) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          !
          xwrk1 = xhigt(1)
          jlow = jlow + 1
          xlowt(jlow) = xwrk1
          xpiv = xwrk1 + 0.5 * (xhigt(ifin) - xwrk1)
          !
          !  One takes values <= pivot to XLOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
              If (jlow >= inth) Exit
            Else
              jhig = jhig + 1
              xhigt(jhig) = xhigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xhigt(1)
        ihig = 1
        Do icrs = 2, jhig
          If (xhigt(icrs) < xmin) Then
            xmin = xhigt(icrs)
            ihig = icrs
          End If
        End Do
        !
        valnth = xhigt(ihig)
        Return
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        xhigt(1) = xlowt(1)
        ilow = 1 + inth - jlow
        Do icrs = 2, inth
          xwrk = xlowt(icrs)
          Do idcr = icrs - 1, max(1, ilow), - 1
            If (xwrk < xhigt(idcr)) Then
              xhigt(idcr + 1) = xhigt(idcr)
            Else
              Exit
            End If
          End Do
          xhigt(idcr + 1) = xwrk
          ilow = ilow + 1
        End Do
        !
        xwrk1 = xhigt(inth)
        ilow = 2 * inth - jlow
        Do icrs = inth + 1, jlow
          If (xlowt(icrs) < xwrk1) Then
            xwrk = xlowt(icrs)
            Do idcr = inth - 1, max(1, ilow), - 1
              If (xwrk >= xhigt(idcr)) Exit
              xhigt(idcr + 1) = xhigt(idcr)
            End Do
            xhigt(idcr + 1) = xlowt(icrs)
            xwrk1 = xhigt(inth)
          End If
          ilow = ilow + 1
        End Do
        !
        valnth = xhigt(inth)
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
 
        imil = (jlow + 1) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xlowt(imil) < xlowt(1)) Then
          xwrk = xlowt(1)
          xlowt(1) = xlowt(imil)
          xlowt(imil) = xwrk
        End If
        If (xlowt(imil) > xlowt(ifin)) Then
          xwrk = xlowt(ifin)
          xlowt(ifin) = xlowt(imil)
          xlowt(imil) = xwrk
          If (xlowt(imil) < xlowt(1)) Then
            xwrk = xlowt(1)
            xlowt(1) = xlowt(imil)
            xlowt(imil) = xwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xlowt(1) + real(inth, sp) / real(jlow + inth, sp) * &
                (xlowt(ifin) - xlowt(1))
 
        !
        !  One takes values > XPIV to XHIGT
        !
        jhig = 0
        jlow = 0
        !
        If (xlowt(ifin) > xpiv) Then
          icrs = 0
          Do
            icrs = icrs + 1
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xlowt(icrs) <= xpiv) Then
                jlow = jlow + 1
                xlowt(jlow) = xlowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = 1, ifin
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xlowt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to find maximum of the 1:INTH set
    !
    valnth = maxval(xlowt(1 : inth))
    Return
    !
    !
  End Function r_valnth
 
  Function i_valnth (XDONT, NORD) Result (valnth)
    !  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
    ! __________________________________________________________
    !  This routine uses a pivoting strategy such as the one of
    !  finding the median based on the quicksort algorithm, but
    !  we skew the pivot choice to try to bring it to NORD as
    !  fast as possible. It uses 2 temporary arrays, where it
    !  stores the indices of the values smaller than the pivot
    !  (ILOWT), and the indices of values larger than the pivot
    !  that we might still need later on (IHIGT). It iterates
    !  until it can bring the number of values in ILOWT to
    !  exactly NORD, and then finds the maximum of this set.
    !  Michel Olagnon - Aug. 2000
    ! __________________________________________________________
    ! __________________________________________________________
    Integer(kind = i4), Dimension (:), Intent (In) :: XDONT
    Integer(kind = i4) :: valnth
    Integer(kind = i4), Intent (In) :: NORD
    ! __________________________________________________________
    Integer(kind = i4), Dimension (SIZE(XDONT)) :: XLOWT, XHIGT
    Integer(kind = i4) :: XPIV, XWRK, XWRK1, XWRK2, XWRK3, XMIN, XMAX
    !
    Integer(kind = i4) :: NDON, JHIG, JLOW, IHIG
    Integer(kind = i4) :: IMIL, IFIN, ICRS, IDCR, ILOW
    Integer(kind = i4) :: JLM2, JLM1, JHM2, JHM1, INTH
    !
    ndon = SIZE (xdont)
    inth = max(min(nord, ndon), 1)
    !
    !    First loop is used to fill-in XLOWT, XHIGT at the same time
    !
    If (ndon < 2) Then
      If (inth == 1) valnth = xdont(1)
      Return
    End If
    !
    !  One chooses a pivot, best estimate possible to put fractile near
    !  mid-point of the set of low values.
    !
    If (xdont(2) < xdont(1)) Then
      xlowt(1) = xdont(2)
      xhigt(1) = xdont(1)
    Else
      xlowt(1) = xdont(1)
      xhigt(1) = xdont(2)
    End If
    !
    If (ndon < 3) Then
      If (inth == 1) valnth = xlowt(1)
      If (inth == 2) valnth = xhigt(1)
      Return
    End If
    !
    If (xdont(3) < xhigt(1)) Then
      xhigt(2) = xhigt(1)
      If (xdont(3) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(3)
      Else
        xhigt(1) = xdont(3)
      End If
    Else
      xhigt(2) = xdont(3)
    End If
    !
    If (ndon < 4) Then
      If (inth == 1) Then
        valnth = xlowt(1)
      Else
        valnth = xhigt(inth - 1)
      End If
      Return
    End If
    !
    If (xdont(ndon) < xhigt(1)) Then
      xhigt(3) = xhigt(2)
      xhigt(2) = xhigt(1)
      If (xdont(ndon) < xlowt(1)) Then
        xhigt(1) = xlowt(1)
        xlowt(1) = xdont(ndon)
      Else
        xhigt(1) = xdont(ndon)
      End If
    Else
      xhigt(3) = xdont(ndon)
    End If
    !
    If (ndon < 5) Then
      If (inth == 1) Then
        valnth = xlowt(1)
      Else
        valnth = xhigt(inth - 1)
      End If
      Return
    End If
    !
 
    jlow = 1
    jhig = 3
    xpiv = xlowt(1) + int(real(2 * inth, sp) / real(ndon + inth, sp), i4) * (xhigt(3) - xlowt(1))
    If (xpiv >= xhigt(1)) Then
      xpiv = xlowt(1) + int(real(2 * inth, sp) / real(ndon + inth, sp), i4) * &
              (xhigt(2) - xlowt(1))
      If (xpiv >= xhigt(1)) &
              xpiv = xlowt(1) + int(real(2 * inth, sp) / real(ndon + inth, sp), i4) * &
                      (xhigt(1) - xlowt(1))
    End If
    !
    !  One puts values > pivot in the end and those <= pivot
    !  at the beginning. This is split in 2 cases, so that
    !  we can skip the loop test a number of times.
    !  As we are also filling in the work arrays at the same time
    !  we stop filling in the XHIGT array as soon as we have more
    !  than enough values in XLOWT.
    !
    !
    If (xdont(ndon) > xpiv) Then
      icrs = 3
      Do
        icrs = icrs + 1
        If (xdont(icrs) > xpiv) Then
          If (icrs >= ndon) Exit
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      !  One restricts further processing because it is no use
      !  to store more high values
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          Else If (icrs >= ndon) Then
            Exit
          End If
        End Do
      End If
      !
      !
    Else
      !
      !  Same as above, but this is not as easy to optimize, so the
      !  DO-loop is kept
      !
      Do icrs = 4, ndon - 1
        If (xdont(icrs) > xpiv) Then
          jhig = jhig + 1
          xhigt(jhig) = xdont(icrs)
        Else
          jlow = jlow + 1
          xlowt(jlow) = xdont(icrs)
          If (jlow >= inth) Exit
        End If
      End Do
      !
      If (icrs < ndon - 1) Then
        Do
          icrs = icrs + 1
          If (xdont(icrs) <= xpiv) Then
            If (icrs >= ndon) Exit
            jlow = jlow + 1
            xlowt(jlow) = xdont(icrs)
          End If
        End Do
      End If
    End If
    !
    jlm2 = 0
    jlm1 = 0
    jhm2 = 0
    jhm1 = 0
    Do
      If (jlm2 == jlow .And. jhm2 == jhig) Then
        !
        !   We are oscillating. Perturbate by bringing JLOW closer by one
        !   to INTH
        !
        If (inth > jlow) Then
          xmin = xhigt(1)
          ihig = 1
          Do icrs = 2, jhig
            If (xhigt(icrs) < xmin) Then
              xmin = xhigt(icrs)
              ihig = icrs
            End If
          End Do
          !
          jlow = jlow + 1
          xlowt(jlow) = xhigt(ihig)
          xhigt(ihig) = xhigt(jhig)
          jhig = jhig - 1
        Else
 
          xmax = xlowt(jlow)
          jlow = jlow - 1
          Do icrs = 1, jlow
            If (xlowt(icrs) > xmax) Then
              xwrk = xmax
              xmax = xlowt(icrs)
              xlowt(icrs) = xwrk
            End If
          End Do
        End If
      End If
      jlm2 = jlm1
      jlm1 = jlow
      jhm2 = jhm1
      jhm1 = jhig
      !
      !   We try to bring the number of values in the low values set
      !   closer to INTH.
      !
      Select Case (inth - jlow)
      Case (2 :)
        !
        !   Not enough values in low part, at least 2 are missing
        !
        inth = inth - jlow
        jlow = 0
        Select Case (jhig)
          !!!!!           CASE DEFAULT
          !!!!!              write (unit=*,fmt=*) "Assertion failed"
          !!!!!              STOP
          !
          !   We make a special case when we have so few values in
          !   the high values set that it is bad performance to choose a pivot
          !   and apply the general algorithm.
          !
        Case (2)
          If (xhigt(1) <= xhigt(2)) Then
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
          Else
            jlow = jlow + 1
            xlowt(jlow) = xhigt(2)
            jlow = jlow + 1
            xlowt(jlow) = xhigt(1)
          End If
          Exit
          !
        Case (3)
          !
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(3)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(3) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          jhig = 0
          Do icrs = jlow + 1, inth
            jhig = jhig + 1
            xlowt(icrs) = xhigt(jhig)
          End Do
          jlow = inth
          Exit
          !
        Case (4 :)
          !
          !
          ifin = jhig
          !
          !  One chooses a pivot from the 2 first values and the last one.
          !  This should ensure sufficient renewal between iterations to
          !  avoid worst case behavior effects.
          !
          xwrk1 = xhigt(1)
          xwrk2 = xhigt(2)
          xwrk3 = xhigt(ifin)
          If (xwrk2 < xwrk1) Then
            xhigt(1) = xwrk2
            xhigt(2) = xwrk1
            xwrk2 = xwrk1
          End If
          If (xwrk2 > xwrk3) Then
            xhigt(ifin) = xwrk2
            xhigt(2) = xwrk3
            xwrk2 = xwrk3
            If (xwrk2 < xhigt(1)) Then
              xhigt(2) = xhigt(1)
              xhigt(1) = xwrk2
            End If
          End If
          !
          xwrk1 = xhigt(1)
          jlow = jlow + 1
          xlowt(jlow) = xwrk1
          xpiv = xwrk1 + (xhigt(ifin) - xwrk1) / 2
          !
          !  One takes values <= pivot to XLOWT
          !  Again, 2 parts, one where we take care of the remaining
          !  high values because we might still need them, and the
          !  other when we know that we will have more than enough
          !  low values in the end.
          !
          jhig = 0
          Do icrs = 2, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
              If (jlow >= inth) Exit
            Else
              jhig = jhig + 1
              xhigt(jhig) = xhigt(icrs)
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xhigt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xhigt(icrs)
            End If
          End Do
        End Select
        !
        !
      Case (1)
        !
        !  Only 1 value is missing in low part
        !
        xmin = xhigt(1)
        ihig = 1
        Do icrs = 2, jhig
          If (xhigt(icrs) < xmin) Then
            xmin = xhigt(icrs)
            ihig = icrs
          End If
        End Do
        !
        valnth = xhigt(ihig)
        Return
        !
        !
      Case (0)
        !
        !  Low part is exactly what we want
        !
        Exit
        !
        !
      Case (-5 : -1)
        !
        !  Only few values too many in low part
        !
        xhigt(1) = xlowt(1)
        ilow = 1 + inth - jlow
        Do icrs = 2, inth
          xwrk = xlowt(icrs)
          Do idcr = icrs - 1, max(1, ilow), - 1
            If (xwrk < xhigt(idcr)) Then
              xhigt(idcr + 1) = xhigt(idcr)
            Else
              Exit
            End If
          End Do
          xhigt(idcr + 1) = xwrk
          ilow = ilow + 1
        End Do
        !
        xwrk1 = xhigt(inth)
        ilow = 2 * inth - jlow
        Do icrs = inth + 1, jlow
          If (xlowt(icrs) < xwrk1) Then
            xwrk = xlowt(icrs)
            Do idcr = inth - 1, max(1, ilow), - 1
              If (xwrk >= xhigt(idcr)) Exit
              xhigt(idcr + 1) = xhigt(idcr)
            End Do
            xhigt(idcr + 1) = xlowt(icrs)
            xwrk1 = xhigt(inth)
          End If
          ilow = ilow + 1
        End Do
        !
        valnth = xhigt(inth)
        Return
        !
        !
      Case (: -6)
        !
        ! last case: too many values in low part
        !
 
        imil = (jlow + 1) / 2
        ifin = jlow
        !
        !  One chooses a pivot from 1st, last, and middle values
        !
        If (xlowt(imil) < xlowt(1)) Then
          xwrk = xlowt(1)
          xlowt(1) = xlowt(imil)
          xlowt(imil) = xwrk
        End If
        If (xlowt(imil) > xlowt(ifin)) Then
          xwrk = xlowt(ifin)
          xlowt(ifin) = xlowt(imil)
          xlowt(imil) = xwrk
          If (xlowt(imil) < xlowt(1)) Then
            xwrk = xlowt(1)
            xlowt(1) = xlowt(imil)
            xlowt(imil) = xwrk
          End If
        End If
        If (ifin <= 3) Exit
        !
        xpiv = xlowt(1) + int(real(inth, sp) / real(jlow + inth, sp), i4) * &
                (xlowt(ifin) - xlowt(1))
 
        !
        !  One takes values > XPIV to XHIGT
        !
        jhig = 0
        jlow = 0
        !
        If (xlowt(ifin) > xpiv) Then
          icrs = 0
          Do
            icrs = icrs + 1
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
              If (icrs >= ifin) Exit
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          If (icrs < ifin) Then
            Do
              icrs = icrs + 1
              If (xlowt(icrs) <= xpiv) Then
                jlow = jlow + 1
                xlowt(jlow) = xlowt(icrs)
              Else
                If (icrs >= ifin) Exit
              End If
            End Do
          End If
        Else
          Do icrs = 1, ifin
            If (xlowt(icrs) > xpiv) Then
              jhig = jhig + 1
              xhigt(jhig) = xlowt(icrs)
            Else
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
              If (jlow >= inth) Exit
            End If
          End Do
          !
          Do icrs = icrs + 1, ifin
            If (xlowt(icrs) <= xpiv) Then
              jlow = jlow + 1
              xlowt(jlow) = xlowt(icrs)
            End If
          End Do
        End If
        !
      End Select
      !
    End Do
    !
    !  Now, we only need to find maximum of the 1:INTH set
    !
    valnth = maxval(xlowt(1 : inth))
    Return
    !
    !
  End Function i_valnth
 
END MODULE mo_orderpack