bat/tests/syntax-tests/highlighted/Fortran (Fixed Form)/quicksort_real_F77.F

C  Fortran 77 implementation of a quicksort algorithm for arrays with
C  real entries.
C  ----------
C  June 2019 
C  Jason Allen Anema, Ph.D.
C  Division of Statistical Genomics
C  Department of Genetics
C  Washington University School of Medicine in St. Louis
C 
C  This work is partially supported NIH grant AG023746
C  ----------
C  Insertion sort is used for short arrays, as quicksort is slower on
C  these.
C  
C  Hoare partition scheme is used (sweeping left and right), as it does
C  three times fewer swaps on average that the Lamuto partition scheme.
C  In conjunction with this, tripartite partition is performed
C  concurrently (solving the "Dutch National Flag problem"). This avoids 
C  horrible runtimes on highly repetitive arrays. For example, without  
C  this, an array of random zeros and ones would have a runtime of
C  O(N^2), but now has a runtime of O(N). The runtime for this algorthm
C  on arrays with k highly repetitive entries is now O(kN).
C    
C  For medium length (sub)arrays, pivots are choosen using
C  Median-of-Three, and those three items are sorted. For longer (sub)arrays
C  the pseudomedian of nine (Median of medians). This avoids O(N^2) runtime on
C  nonrandom inputs such as increasing and decreasing sequences. 
C
C  See Louis Bentley, Jon & McIlroy, Douglas. (1993). Engineering a Sort Function.
C  Softw., Pract. Exper.. 23. 1249-1265. 10.1002/spe.4380231105 for details. 
C
C  The ordering on elements of the array are defined by a comparison
C  function,compar, that is a user-supplied INTEGER*2 function of the form
C           compar(a,b) which returns:
C              -1 if a precedes b
C              +1 if b precedes a
C              0 is a and b are considered equivalent
C  and thus defines a total ordering.
C  
C  If one would like to use the standard order on integers, the
C  compar function could be written in a file "compint.F" as:
C  ----------------------------------------------------------------
C      INTEGER*2 FUNCTION compint(a,b)
C      INTEGER a, b
C      if(a.lt.b)then
C         compint = -1
C      elseif(a.gt.b)then
C         compint = +1
C      else
C         compint = 0
C      endif
C      END
C  ----------------------------------------------------------------
C  Then in your program, call quicksort with:
C      call quicksort_real_F77(array, n, compint)
C
C  The maximal length of an array in this implementation is (2^31-1),
C  but can be changed to allow for length up to (2^63-1) by changing the
C  data types of the relevant variables and constants. If you wish to 
C  sort longer arrays, of length N, you'll need to customize variable 
C  and constant types and set mstack to be at least (2*log_2(N)+2). 
C
C  ----------------------------------------------------------------
C  Copyright 2019 Jason Allen Anema
C  
C  Permission is hereby granted, free of charge, to any person obtaining
C  a copy of this software and associated documentation files (the "Software"),
C  to deal in the Software without restriction, including without limitation the
C  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
C  sell copies of the Software, and to permit persons to whom the Software is
C  furnished to do so, subject to the following conditions:
C
C  The above copyright notice and this permission notice shall be included
C  in all copies or substantial portions of the Software.
C
C  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
C  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
C  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
C  THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
C  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
C  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
C  IN THE SOFTWARE.
C  -------------------------------------------------------------------
C
      SUBROUTINE quicksort_real_F77(array,n,compar)
      INTEGER n, maxins, maxmid, mstack
      REAL array(n)
      PARAMETER (maxins = 7, maxmid = 40, mstack = 128)
C        maxins: maximal size of (sub)arrays to be sorted with
C           insertion sort.
C        maxmid: maximal size of (sub)arrays that will be quicksorted with
C           Median-of-Three pivots.
C        mstack: maximal size of required auxiliary storage (a stack), plus 2 
C           extra spots, which tracks the starts and ends of yet unsorted 
C           subarrays. mstack = 130 is large enough to handle arrays up to 
C           length 2^63-1. This maximal size follows from
C           processing smaller arrays first and pigeonhole principal.
C 
      INTEGER  a, d, i, j, k, s, lo, mid, hi, tstack, bstack(mstack)
C        a, d, i, j, k, s: indices
C        lo, mid, and hi: their natural location in a (sub)array
C        tstack:  equal to twice the number of additional subarrays still 
C          needing to be sorted
C        bstack: stack of the endpoints of unsorted subarrays
      INTEGER pm1, pm2, pm3, pm4, pm5, pm6, pm7, pm8, pm9
C        for pseudomedian of nine positions in (sub)arrays
      REAL piv, temp
C        piv is to store the pivot's value
C    
      EXTERNAL compar
      INTEGER*2 compar
C        compar is a user-supplied INTEGER*2 function of the form
C           compar(a,b) which returns:
C              -1 if a precedes b
C              +1 if b precedes a
C              0 is a and b are considered equivalent
C           and thus defines a total ordering. 
      tstack = 0
      lo = 1 
      hi = n
C
C  Insertion sort subarrays of size maxins or less
 1    if(hi-lo+1.le.maxins)then
         do 10, i = lo + 1, hi, 1
            temp = array(i)
            do 11 j = i - 1, lo, -1
               if(compar(array(j), temp).le.0)goto 2
               array(j+1)=array(j)
 11         continue
            j = lo - 1
 2          array(j+1) = temp
 10      continue
         if(tstack.eq.0)return
C  Pop the bstack, and start new partitioning
         hi = bstack(tstack)
         lo = bstack(tstack-1)
         tstack = tstack - 2
      else
C  Use Median-of-Three as choice of pivot (median of lo, middle, hi)
C  and reorder those elements appropriately when subarrays are medium
C  length (between maxins and maxmid)
         mid = lo +  (hi-lo)/2
         if(hi-lo.le.maxmid)then
            if(compar(array(mid), array(lo)).eq.-1)then
               temp = array(lo)
               array(lo) = array(mid)
               array(mid) = temp
            endif
            if(compar(array(hi), array(lo)).eq.-1)then
               temp = array(hi)
               array(hi) = array(lo)
               array(lo) = temp
            endif
            if(compar(array(hi), array(mid)).eq.-1)then
               temp = array(hi)
               array(hi) = array(mid)
               array(mid) = temp
            endif
C  Use pseudomedian of nine (Median of medians) as choice of pivot when 
C  subarrays are longer than maxmid. Note that doing it this way requires only 12
C  comparisons for finding the pivot.
         elseif(hi-lo+1.gt.maxmid)then
            pm1 = lo
            pm5 = lo + (hi-lo)/2
            pm9 = hi
            pm3 = lo + (pm5-lo)/2
            pm7 = pm5 + (hi-pm5)/2
            pm2 = lo + (pm3-lo)/2
            pm4 = pm3 + (pm5-pm3)/2
            pm6 = pm5 + (pm7-pm5)/2
            pm8 = pm7 + (pm9-pm7)/2
C  Median and sorting for pm1, pm2, pm3
            if(compar(array(pm2), array(pm1)).eq.-1)then
               temp = array(pm1)
               array(pm1) = array(pm2)
               array(pm2) = temp
            endif
            if(compar(array(pm3), array(pm1)).eq.-1)then
               temp = array(pm3)
               array(pm3) = array(pm1)
               array(pm1) = temp
            endif
            if(compar(array(pm3), array(pm2)).eq.-1)then
               temp = array(pm3)
               array(pm3) = array(pm2)
               array(pm2) = temp
            endif
C  Median and sorting for pm4, pm5, pm6
            if(compar(array(pm5), array(pm4)).eq.-1)then
               temp = array(pm4)
               array(pm4) = array(pm5)
               array(pm5) = temp
            endif
            if(compar(array(pm6), array(pm4)).eq.-1)then
               temp = array(pm6)
               array(pm6) = array(pm4)
               array(pm4) = temp
            endif
            if(compar(array(pm6), array(pm5)).eq.-1)then
               temp = array(pm6)
               array(pm6) = array(pm5)
               array(pm5) = temp
            endif
C  Median and sorting for pm7, pm8, pm9
            if(compar(array(pm8), array(pm7)).eq.-1)then
               temp = array(pm7)
               array(pm7) = array(pm8)
               array(pm8) = temp
            endif
            if(compar(array(pm9), array(pm7)).eq.-1)then
               temp = array(pm9)
               array(pm9) = array(pm7)
               array(pm7) = temp
            endif
            if(compar(array(pm9), array(pm8)).eq.-1)then
               temp = array(pm9)
               array(pm9) = array(pm8)
               array(pm8) = temp
            endif
C Median of the medians (which are now pm2, pm5, pm8)
            if(compar(array(pm5), array(pm2)).eq.-1)then
               temp = array(pm2)
               array(pm2) = array(pm5)
               array(pm5) = temp
            endif
            if(compar(array(pm8), array(pm2)).eq.-1)then
               temp = array(pm8)
               array(pm8) = array(pm2)
               array(pm2) = temp
            endif
            if(compar(array(pm8), array(pm5)).eq.-1)then
               temp = array(pm8)
               array(pm8) = array(pm5)
               array(pm5) = temp
            endif
         endif
C  Pivot assigned for medium and long length subarrays.
C  Note that pm5 = mid
             piv = array(mid)
C  Initialize pointers for partitioning
            i = lo-1
            j = hi+1
C  Initialize counts of repeat values of pivot.
            a = 0
            d = 0
C  Beginning of outer loop for placing pivot.
 3       continue
C  Scan up to find an element > piv.
            i = i + 1
C  Check if pointers crossed.
         if(j.lt.i)goto 5
C  Check if i pointer hit hi boundary.
         if(i.eq.hi)goto 4
C      
         if(compar(array(i), piv).eq.-1)goto 3
C Check for copies of pivot from scanning right. 
         if(compar(array(i), piv).eq.0)then
             array(i) = array(lo+a)
             array(lo+a) = piv
             a = a + 1
             goto 3 
         endif
C  Beginning of innerloop for placing pivot.
 4       continue
C  Scan down to find an element < piv.
            j = j - 1
C  Check if pointers crossed.
         if(j.lt.i)goto 5
         if(compar(array(j), piv).eq.1)goto 4
C  Check for copies of pivot from scanning left. 
         if(compar(array(j), piv).eq.0)then
            array(j) = array(hi-d)
            array(hi-d) = piv
            d = d + 1
            goto 4      
         endif
C Check if pointers crossed.
         if(j.lt.i)goto 5
C  Exchange elements
         temp = array(i)
         array(i) = array(j)
         array(j) = temp
C  End of outermost loop for placing pivot.
         goto 3
C  Insert all copies of pivot in appropriate place
 5       s = MIN(a, j-lo-a+1)
         DO 6 k = 1, s
            array(lo-1+k) = array(i-k)
            array(i-k) = piv
 6       CONTINUE
         s = MIN(d, hi-j-d)
         DO 7 k = 1, s
            array(hi+1-k) = array(j+k)
            array(j+k) = piv
 7       CONTINUE
C  Increase effective stack size
         tstack = tstack + 2 
C  Push pointers to larger subarray on stack for later processing,
C  process smaller subarray immediately. 
         if(tstack.gt.mstack) THEN
           WRITE(*,*)'Stack size is too small in quicksort fortran code quicksort_real_F77.F' 
           WRITE(*,*)'Are you sure you want to sort an array this long?'
           WRITE(*,*)'Your array has more than 2^63-1  entries?'
           WRITE(*,*)'If so, set mstack parameter to be at least:'
           WRITE(*,*)'2*ceiling(log_2(N))+2, for N = length of array,'
           WRITE(*,*)'and recompile this subroutine.'
           RETURN 
         endif
         if(hi-j-d-1.ge.j-a-lo)then
            bstack(tstack) = hi
            bstack(tstack-1) = MIN(j+d+1, hi)
            hi=MAX(j-a,lo)
         else
            bstack(tstack)=MAX(j-a,lo)
            bstack(tstack-1)=lo
            lo=MIN(j+d+1,hi)
         endif
C
C     end of outermost if statement 
      endif
      goto 1
C     END of subroutine quicksort
      END