The ParaMonte Documentation Website
Current view: top level - kernel - Sort_mod.f90 (source / functions) Hit Total Coverage
Test: ParaMonte 1.5.1 :: MPI Parallel Kernel - Code Coverage Report Lines: 213 214 99.5 %
Date: 2021-01-08 13:07:16 Functions: 10 10 100.0 %
Legend: Lines: hit not hit

          Line data    Source code
       1             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       2             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       3             : !!!!
       4             : !!!!   MIT License
       5             : !!!!
       6             : !!!!   ParaMonte: plain powerful parallel Monte Carlo library.
       7             : !!!!
       8             : !!!!   Copyright (C) 2012-present, The Computational Data Science Lab
       9             : !!!!
      10             : !!!!   This file is part of the ParaMonte library.
      11             : !!!!
      12             : !!!!   Permission is hereby granted, free of charge, to any person obtaining a
      13             : !!!!   copy of this software and associated documentation files (the "Software"),
      14             : !!!!   to deal in the Software without restriction, including without limitation
      15             : !!!!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
      16             : !!!!   and/or sell copies of the Software, and to permit persons to whom the
      17             : !!!!   Software is furnished to do so, subject to the following conditions:
      18             : !!!!
      19             : !!!!   The above copyright notice and this permission notice shall be
      20             : !!!!   included in all copies or substantial portions of the Software.
      21             : !!!!
      22             : !!!!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
      23             : !!!!   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
      24             : !!!!   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
      25             : !!!!   IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
      26             : !!!!   DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
      27             : !!!!   OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
      28             : !!!!   OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
      29             : !!!!
      30             : !!!!   ACKNOWLEDGMENT
      31             : !!!!
      32             : !!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
      33             : !!!!   As per the ParaMonte library license agreement terms, if you use any parts of
      34             : !!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
      35             : !!!!   work (education/research/industry/development/...) by citing the ParaMonte
      36             : !!!!   library as described on this page:
      37             : !!!!
      38             : !!!!       https://github.com/cdslaborg/paramonte/blob/main/ACKNOWLEDGMENT.md
      39             : !!!!
      40             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      41             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      42             : 
      43             : !>  \brief This module contains procedures for sorting arrays.
      44             : !>  \author Amir Shahmoradi
      45             : 
      46             : module Sort_mod
      47             : 
      48             :     implicit none
      49             : 
      50             :     character(*), parameter :: MODULE_NAME = "@Sort_mod"
      51             : 
      52             :     interface sortArray
      53             :         module procedure :: sortArray_RK, sortAscending_RK, sortAscendingWithRooter_RK
      54             :     end interface sortArray
      55             : 
      56             :     interface sortAscending
      57             :         module procedure :: sortAscending_RK, sortAscendingWithRooter_RK
      58             :     end interface sortAscending
      59             : 
      60             :     interface indexArray
      61             :         module procedure :: indexArray_IK, indexArray_RK
      62             :     end interface indexArray
      63             : 
      64             :     interface getMedian
      65             :         module procedure :: getMedian_RK
      66             :     end interface getMedian
      67             : 
      68             : contains
      69             : 
      70             : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      71             : 
      72             :     !> \brief
      73             :     !> Sort (recursively) the input real array of arbitrary size from the smallest value to the largest and
      74             :     !> return the result inside the input array.
      75             :     !>
      76             :     !> @param[inout] array : The input vector to be sorted.
      77             :     !>
      78             :     !> \warning
      79             :     !> On return, the contents of the input array is completely overwritten.
      80         297 :     pure recursive subroutine sortArray_RK(array)
      81             : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
      82             :         !DEC$ ATTRIBUTES DLLEXPORT :: sortArray_RK
      83             : #endif
      84             :         use Constants_mod, only: IK, RK
      85             :         implicit none
      86             :         real(RK), intent(inout) :: array(:)
      87             :         integer(IK)             :: iq
      88             : 
      89         297 :         if(size(array) > 1) then
      90         147 :             call partition(array, iq)
      91         147 :             call sortArray_RK(array(:iq-1))
      92         147 :             call sortArray_RK(array(iq:))
      93             :         endif
      94         297 :     end subroutine sortArray_RK
      95             : 
      96             : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      97             : 
      98         294 :     pure subroutine partition(array, marker)
      99             : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
     100             :         !DEC$ ATTRIBUTES DLLEXPORT :: partition
     101             : #endif
     102             :         use Constants_mod, only: IK, RK
     103             :         implicit none
     104             :         real(RK)   , intent(inout) :: array(:)
     105             :         integer(IK), intent(out)   :: marker
     106             :         integer(IK)                :: i, j
     107         147 :         real(RK)                   :: temp
     108         147 :         real(RK)                   :: x      ! pivot point
     109         147 :         x = array(1)
     110         147 :         i= 0
     111         147 :         j= size(array) + 1
     112         225 :         do
     113         372 :             j = j-1
     114         312 :             do
     115         684 :                 if (array(j) <= x) exit
     116         312 :                 j = j-1
     117             :             end do
     118         372 :             i = i+1
     119         159 :             do
     120         531 :                 if (array(i) >= x) exit
     121         159 :                 i = i+1
     122             :             end do
     123         372 :             if (i < j) then ! exchange array(i) and array(j)
     124         225 :                 temp = array(i)
     125         225 :                 array(i) = array(j)
     126         225 :                 array(j) = temp
     127         147 :             elseif (i == j) then
     128          39 :                 marker = i+1
     129          39 :                 return
     130             :             else
     131         108 :                 marker = i
     132         108 :                 return
     133             :             endif
     134             :         end do
     135         147 :   end subroutine partition
     136             : 
     137             : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     138             : 
     139             :     !> \brief
     140             :     !> Sort (recursively) the input real array of arbitrary size from the smallest value to the largest and
     141             :     !> return the result inside the input array.
     142             :     !>
     143             :     !> @param[in]       np      :   The length of the input vector to be sorted.
     144             :     !> @param[inout]    Point   :   The input vector to be sorted.
     145             :     !> @param[out]      Err     :   An object of class [Err_type](@ref err_mod::err_type).
     146             :     !>
     147             :     !> \warning
     148             :     !> On return, the contents of the input array is completely overwritten by the output sorted array.
     149             :     !>
     150             :     !> \warning
     151             :     !> On return, the value of `Err%occurred` must be checked for any potential occurrences of errors during sorting.
     152         631 :     pure subroutine sortAscending_RK(np,Point,Err)
     153             : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
     154             :         !DEC$ ATTRIBUTES DLLEXPORT :: sortAscending_RK
     155             : #endif
     156         147 :         use Constants_mod, only: IK, RK
     157             :         use Misc_mod, only: swap
     158             :         use Err_mod, only: Err_type
     159             : 
     160             :         implicit none
     161             : 
     162             :         integer(IK)     , parameter     :: nn = 15, NSTACK = 100
     163             :         integer(IK)     , intent(in)    :: np
     164             :         real(RK)        , intent(inout) :: Point(np)
     165             :         type(Err_type)  , intent(out)   :: Err
     166             : 
     167             :         character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@sortAscending_RK()"
     168         577 :         real(RK)                        :: dummy
     169             :         integer(IK)                     :: k,i,j,jstack,m,r,istack(NSTACK)
     170             : 
     171         577 :         Err%occurred = .false.
     172             : 
     173         577 :         jstack=0
     174         577 :         m = 1
     175         577 :         r = np
     176      137442 :         do
     177      138019 :             if (r-m < nn) then
     178      647511 :                 do j = m+1,r
     179      578213 :                     dummy = Point(j)
     180     1371060 :                     do i = j-1,m,-1
     181     1328240 :                         if (Point(i) <=  dummy) exit
     182      835671 :                         Point(i+1) = Point(i)
     183             :                     end do
     184      647511 :                     Point(i+1) = dummy
     185             :                 end do
     186       69298 :                 if (jstack == 0) return
     187       68721 :                 r = istack(jstack)
     188       68721 :                 m = istack(jstack-1)
     189       68721 :                 jstack = jstack-2
     190             :             else
     191       68721 :                 k = (m+r)/2
     192       68721 :                 call swap(Point(k),Point(m+1))
     193       68721 :                 if (Point(m)>Point(r)) call swap(Point(m),Point(r))
     194       68721 :                 if (Point(m+1)>Point(r)) call swap(Point(m+1),Point(r))
     195       68721 :                 if (Point(m)>Point(m+1)) call swap(Point(m),Point(m+1))
     196       68721 :                 i = m+1
     197       68721 :                 j = r
     198       68721 :                 dummy = Point(m+1)
     199     1434160 :                 do
     200     1848610 :                     do
     201     3351500 :                         i = i+1
     202     3351500 :                         if (Point(i) >= dummy) exit
     203             :                     end do
     204     1730620 :                     do
     205     3233500 :                         j = j-1
     206     3233500 :                         if (Point(j) <= dummy) exit
     207             :                     end do
     208     1502890 :                     if (j < i) exit
     209     1434160 :                     call swap(Point(i),Point(j))
     210             :                 end do
     211       68721 :                 Point(m+1) = Point(j)
     212       68721 :                 Point(j) = dummy
     213       68721 :                 jstack = jstack+2
     214       68721 :                 if (jstack > NSTACK) then
     215             :                     ! LCOV_EXCL_START
     216             :                     Err%occurred = .true.
     217             :                     Err%msg = PROCEDURE_NAME//": NSTACK is too small."
     218             :                     return
     219             :                     ! LCOV_EXCL_STOP
     220             :                 end if
     221       68721 :                 if (r-i+1 >= j-m) then
     222       37509 :                     istack(jstack) = r
     223       37509 :                     istack(jstack-1) = i
     224       37509 :                     r = j-1
     225             :                 else
     226       31212 :                     istack(jstack) = j-1
     227       31212 :                     istack(jstack-1) = m
     228       31212 :                     m = i
     229             :                 end if
     230             :             end if
     231             :         end do
     232         577 :     end subroutine sortAscending_RK
     233             : 
     234             : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     235             : 
     236             :     !> \brief
     237             :     !> Given the real `Array(1:n)` return the array `Indx(1:n)` such that `Array(Indx(j)), j=1:n` is in ascending order.
     238             :     !>
     239             :     !> @param[in]   n       :   The length of the input vector to be sorted.
     240             :     !> @param[in]   Array   :   The input vector of length `n` to be sorted.
     241             :     !> @param[out]  Indx    :   The output integer vector of indices of the sorted vector.
     242             :     !> @param[out]  Err     :   An object of class [Err_type](@ref err_mod::err_type).
     243             :     !>
     244             :     !> \warning
     245             :     !> On return, the value of `Err%%occurred` must be checked for any potential occurrences of errors during sorting.
     246         859 :     pure subroutine indexArray_RK(n,Array,Indx,Err)
     247             : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
     248             :         !DEC$ ATTRIBUTES DLLEXPORT :: indexArray_RK
     249             : #endif
     250         577 :         use Constants_mod, only: IK, RK
     251             :         use Misc_mod, only: swap
     252             :         use Err_mod, only: Err_type
     253             : 
     254             :         implicit none
     255             : 
     256             :         integer(IK)     , intent(in)    :: n
     257             :         real(RK)        , intent(in)    :: Array(n)
     258             :         integer(IK)     , intent(out)   :: Indx(n)
     259             :         type(Err_type)  , intent(out)   :: Err
     260             : 
     261             :         character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@indexArray_RK()"
     262             :         integer(IK)     , parameter     :: nn=15, NSTACK=50
     263             :         integer(IK)                     :: k,i,j,indext,jstack,l,r
     264             :         integer(IK)                     :: istack(NSTACK)
     265         859 :         real(RK)                        :: a
     266             : 
     267         859 :         Err%occurred = .false.
     268             : 
     269      237596 :         do j = 1,n
     270      237596 :             Indx(j) = j
     271             :         end do
     272         859 :         jstack=0
     273         859 :         l=1
     274         859 :         r=n
     275       47101 :         do
     276       47101 :             if (r-l < nn) then
     277      213616 :                 do j=l+1,r
     278      189636 :                     indext=Indx(j)
     279      189636 :                     a=Array(indext)
     280      692772 :                     do i=j-1,l,-1
     281      652182 :                         if (Array(Indx(i)) <= a) exit
     282      543726 :                         Indx(i+1)=Indx(i)
     283             :                     end do
     284      213616 :                     Indx(i+1)=indext
     285             :                 end do
     286       23980 :                 if (jstack == 0) return
     287       23121 :                 r=istack(jstack)
     288       23121 :                 l=istack(jstack-1)
     289       23121 :                 jstack=jstack-2
     290             :             else
     291       23121 :                 k=(l+r)/2
     292       23121 :                 call swap(Indx(k),Indx(l+1))
     293       23121 :                 call exchangeIndex(Indx(l),Indx(r))
     294       23121 :                 call exchangeIndex(Indx(l+1),Indx(r))
     295       23121 :                 call exchangeIndex(Indx(l),Indx(l+1))
     296       23121 :                 i=l+1
     297       23121 :                 j=r
     298       23121 :                 indext=Indx(l+1)
     299       23121 :                 a=Array(indext)
     300      264484 :                 do
     301      397655 :                     do
     302      685260 :                         i=i+1
     303      685260 :                         if (Array(Indx(i)) >= a) exit
     304             :                     end do
     305      373632 :                     do
     306      661237 :                         j=j-1
     307      661237 :                         if (Array(Indx(j)) <= a) exit
     308             :                     end do
     309      287605 :                     if (j < i) exit
     310      264484 :                     call swap(Indx(i),Indx(j))
     311             :                 end do
     312       23121 :                 Indx(l+1)=Indx(j)
     313       23121 :                 Indx(j)=indext
     314       23121 :                 jstack=jstack+2
     315       23121 :                 if (jstack > NSTACK) then
     316             :                     ! LCOV_EXCL_START
     317             :                     Err%occurred = .true.
     318             :                     Err%msg = PROCEDURE_NAME//": NSTACK is too small."
     319             :                     return
     320             :                     ! LCOV_EXCL_STOP
     321             :                 end if
     322       23121 :                 if (r-i+1 >= j-l) then
     323       11602 :                     istack(jstack)=r
     324       11602 :                     istack(jstack-1)=i
     325       11602 :                     r=j-1
     326             :                 else
     327       11519 :                     istack(jstack)=j-1
     328       11519 :                     istack(jstack-1)=l
     329       11519 :                     l=i
     330             :                 end if
     331             :             end if
     332             :         end do
     333             :     contains
     334       69363 :         pure subroutine exchangeIndex(i,j)
     335             :             integer(IK), intent(inout) :: i,j
     336             :             integer(IK)                :: swp
     337       69363 :             if (Array(j) < Array(i)) then
     338       26626 :                 swp=i
     339       26626 :                 i=j
     340       26626 :                 j=swp
     341             :             end if
     342         859 :         end subroutine exchangeIndex
     343             :     end subroutine indexArray_RK
     344             : 
     345             : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     346             : 
     347             :     !> \brief
     348             :     !> Given the integer `Array(1:n)` return the array `Indx(1:n)` such that `Array(Indx(j)), j=1:n` is in ascending order.
     349             :     !>
     350             :     !> @param[in]   n       :   The length of the input vector to be sorted.
     351             :     !> @param[in]   Array   :   The input vector of length `n` to be sorted.
     352             :     !> @param[out]  Indx    :   The output integer vector of indices of the sorted vector.
     353             :     !> @param[out]  Err     :   An object of class [Err_type](@ref err_mod::err_type).
     354             :     !>
     355             :     !> \warning
     356             :     !> On return, the value of `Err%%occurred` must be checked for any potential occurrences of errors during sorting.
     357         218 :     pure subroutine indexArray_IK(n,Array,Indx,Err)
     358             : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
     359             :         !DEC$ ATTRIBUTES DLLEXPORT :: indexArray_IK
     360             : #endif
     361             :         use Constants_mod, only: IK, RK
     362             :         use Misc_mod, only: swap
     363             :         use Err_mod, only: Err_type
     364             : 
     365             :         implicit none
     366             : 
     367             :         integer(IK)     , intent(in)    :: n
     368             :         integer(IK)     , intent(in)    :: Array(n)
     369             :         integer(IK)     , intent(out)   :: Indx(n)
     370             :         type(Err_type)  , intent(out)   :: Err
     371             : 
     372             :         character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@indexArray_IK()"
     373             :         integer(IK)     , parameter     :: nn=15_IK, NSTACK=50_IK
     374             :         integer(IK)                     :: k,i,j,indext,jstack,l,r
     375             :         integer(IK)                     :: istack(NSTACK)
     376             :         integer(IK)                     :: a
     377             : 
     378         218 :         Err%occurred = .false.
     379             : 
     380        1039 :         do j = 1,n
     381        1039 :             Indx(j) = j
     382             :         end do
     383         218 :         jstack=0
     384         218 :         l=1
     385         218 :         r=n
     386         242 :         do
     387         242 :             if (r-l < nn) then
     388         809 :                 do j=l+1,r
     389         579 :                     indext=Indx(j)
     390         579 :                     a=Array(indext)
     391         998 :                     do i=j-1,l,-1
     392         968 :                         if (Array(Indx(i)) <= a) exit
     393         449 :                         Indx(i+1)=Indx(i)
     394             :                     end do
     395         809 :                     Indx(i+1)=indext
     396             :                 end do
     397         230 :                 if (jstack == 0) return
     398          12 :                 r=istack(jstack)
     399          12 :                 l=istack(jstack-1)
     400          12 :                 jstack=jstack-2
     401             :             else
     402          12 :                 k=(l+r)/2
     403          12 :                 call swap(Indx(k),Indx(l+1))
     404          12 :                 call exchangeIndex(Indx(l),Indx(r))
     405          12 :                 call exchangeIndex(Indx(l+1),Indx(r))
     406          12 :                 call exchangeIndex(Indx(l),Indx(l+1))
     407          12 :                 i=l+1
     408          12 :                 j=r
     409          12 :                 indext=Indx(l+1)
     410          12 :                 a=Array(indext)
     411          66 :                 do
     412         174 :                     do
     413         252 :                         i=i+1
     414         252 :                         if (Array(Indx(i)) >= a) exit
     415             :                     end do
     416          63 :                     do
     417         141 :                         j=j-1
     418         141 :                         if (Array(Indx(j)) <= a) exit
     419             :                     end do
     420          78 :                     if (j < i) exit
     421          66 :                     call swap(Indx(i),Indx(j))
     422             :                 end do
     423          12 :                 Indx(l+1)=Indx(j)
     424          12 :                 Indx(j)=indext
     425          12 :                 jstack=jstack+2
     426          12 :                 if (jstack > NSTACK) then
     427             :                     ! LCOV_EXCL_START
     428             :                     Err%occurred = .true.
     429             :                     Err%msg = PROCEDURE_NAME//": NSTACK is too small."
     430             :                     return
     431             :                     ! LCOV_EXCL_STOP
     432             :                 end if
     433          12 :                 if (r-i+1 >= j-l) then
     434           3 :                     istack(jstack)=r
     435           3 :                     istack(jstack-1)=i
     436           3 :                     r=j-1
     437             :                 else
     438           9 :                     istack(jstack)=j-1
     439           9 :                     istack(jstack-1)=l
     440           9 :                     l=i
     441             :                 end if
     442             :             end if
     443             :         end do
     444             :     contains
     445          36 :         pure subroutine exchangeIndex(i,j)
     446             :             integer(IK), intent(inout) :: i,j
     447             :             integer(IK)                :: swp
     448          36 :             if (Array(j) < Array(i)) then
     449          18 :                 swp=i
     450          18 :                 i=j
     451          18 :                 j=swp
     452             :             end if
     453         218 :         end subroutine exchangeIndex
     454             :   end subroutine indexArray_IK
     455             : 
     456             : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     457             : 
     458             :     !> \brief
     459             :     !> Sort the real `Leader(1:lenLeader)` in ascending order using Quicksort while making the corresponding rearrangement of real `Rooter(1:lenLeader)`.
     460             :     !>
     461             :     !> @param[in]       lenLeader   :   The length of the input vector to be sorted.
     462             :     !> @param[inout]    Leader      :   The vector of length `lenLeader` to be sorted.
     463             :     !> @param[inout]    Rooter      :   The vector of length `lenLeader` to be sorted according to the rearrangement of the elements of `Leader`.
     464             :     !> @param[out]      Err         :   An object of class [Err_type](@ref err_mod::err_type).
     465             :     !>
     466             :     !> \warning
     467             :     !> On return, the value of `Err%%occurred` must be checked for any potential occurrences of errors during sorting.
     468           3 :     pure subroutine sortAscendingWithRooter_IK(lenLeader,Leader,Rooter,Err)
     469             : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
     470             :         !DEC$ ATTRIBUTES DLLEXPORT :: sortAscendingWithRooter_IK
     471             : #endif
     472             :         use Constants_mod, only: IK
     473             :         use Err_mod, only: Err_type
     474             : 
     475             :         implicit none
     476             : 
     477             :         integer(IK)     , intent(in)    :: lenLeader
     478             :         integer(IK)     , intent(inout) :: Leader(lenLeader), Rooter(lenLeader)
     479             :         type(Err_type)  , intent(out)   :: Err
     480             : 
     481             :         character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@sortAscendingWithRooter_RK()"
     482           3 :         integer(IK)                     :: Indx(lenLeader)
     483             : 
     484           3 :         call indexArray_IK(lenLeader,Leader,Indx,Err)
     485             :         ! LCOV_EXCL_START
     486             :         if (Err%occurred) then
     487             :             Err%msg = PROCEDURE_NAME//": NSTACK is too small."
     488             :             return
     489             :         end if
     490             :         ! LCOV_EXCL_STOP
     491         303 :         Leader = Leader(Indx)
     492         303 :         Rooter = Rooter(Indx)
     493           3 :     end subroutine sortAscendingWithRooter_IK
     494             : 
     495             : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     496             : 
     497             :     !> \brief
     498             :     !> Sort the real `Leader(1:lenLeader)` in ascending order using Quicksort while making the corresponding rearrangement of real `Rooter(1:lenLeader)`.
     499             :     !>
     500             :     !> @param[in]       lenLeader   :   The length of the input vector to be sorted.
     501             :     !> @param[inout]    Leader      :   The vector of length `lenLeader` to be sorted.
     502             :     !> @param[inout]    Rooter      :   The vector of length `lenLeader` to be sorted according to the rearrangement of the elements of `Leader`.
     503             :     !> @param[out]      Err         :   An object of class [Err_type](@ref err_mod::err_type).
     504             :     !>
     505             :     !> \warning
     506             :     !> On return, the value of `Err%%occurred` must be checked for any potential occurrences of errors during sorting.
     507          15 :     pure subroutine sortAscendingWithRooter_RK(lenLeader,Leader,Rooter,Err)
     508             : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
     509             :         !DEC$ ATTRIBUTES DLLEXPORT :: sortAscendingWithRooter_RK
     510             : #endif
     511           3 :         use Constants_mod, only: IK, RK
     512             :         use Err_mod, only: Err_type
     513             : 
     514             :         implicit none
     515             : 
     516             :         integer(IK)     , intent(in)    :: lenLeader
     517             :         real(RK)        , intent(inout) :: Leader(lenLeader), Rooter(lenLeader)
     518             :         type(Err_type)  , intent(out)   :: Err
     519             : 
     520             :         character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@sortAscendingWithRooter_RK()"
     521          15 :         integer(IK)                     :: Indx(lenLeader)
     522             : 
     523          15 :         call indexArray_RK(lenLeader,Leader,Indx,Err)
     524             :         ! LCOV_EXCL_START
     525             :         if (Err%occurred) then
     526             :             Err%msg = PROCEDURE_NAME//": NSTACK is too small."
     527             :             return
     528             :         end if
     529             :         ! LCOV_EXCL_STOP
     530        1515 :         Leader = Leader(Indx)
     531        1515 :         Rooter = Rooter(Indx)
     532          15 :     end subroutine sortAscendingWithRooter_RK
     533             : 
     534             : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     535             : 
     536             :     !> \brief
     537             :     !> Return the median of the input vector.
     538             :     !>
     539             :     !> @param[in]       lenArray    :   The length of the input vector.
     540             :     !> @param[in]       Array       :   The input vector of length `lenArray` whose median is to be found.
     541             :     !> @param[out]      median      :   The median of the input `Array`.
     542             :     !> @param[out]      Err         :   An object of class [Err_type](@ref err_mod::err_type).
     543             :     !>
     544             :     !> \warning
     545             :     !> On return, the value of `Err%%occurred` must be checked for any potential occurrences of errors during sorting.
     546          94 :     pure subroutine getMedian_RK(lenArray,Array,median,Err)
     547             : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
     548             :         !DEC$ ATTRIBUTES DLLEXPORT :: getMedian_RK
     549             : #endif
     550          15 :         use Constants_mod, only: IK, RK
     551             :         use Err_mod, only: Err_type
     552             : 
     553             :         implicit none
     554             : 
     555             :         integer(IK)     , intent(in)    :: lenArray
     556             :         real(RK)        , intent(in)    :: Array(lenArray)
     557             :         real(RK)        , intent(out)   :: median
     558             :         type(Err_type)  , intent(out)   :: Err
     559             : 
     560             :         character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@median_RK()"
     561         655 :         real(RK)                        :: ArrayDummy(lenArray)
     562             :         integer(IK)                     :: lenArrayHalf
     563             : 
     564         655 :         ArrayDummy = Array
     565          94 :         call sortAscending(np=lenArray,Point=ArrayDummy,Err=Err)
     566             :         ! LCOV_EXCL_START
     567             :         if (Err%occurred) then
     568             :             Err%msg = PROCEDURE_NAME//Err%msg
     569             :             return
     570             :         end if
     571             :         ! LCOV_EXCL_STOP
     572             : 
     573          94 :         lenArrayHalf = lenArray / 2
     574          94 :         median = ArrayDummy(lenArrayHalf+1)
     575          94 :         if (2*lenArrayHalf==lenArray) median = 0.5_RK * ( ArrayDummy(lenArrayHalf) + median )
     576             : 
     577          94 :     end subroutine getMedian_RK
     578             : 
     579             : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     580             : 
     581           0 : end module Sort_mod

ParaMonte: Plain Powerful Parallel Monte Carlo Library 
The Computational Data Science Lab
© Copyright 2012 - 2021