Add Fortran (Fixed Form) syntax test file

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

@@ -0,0 +1,323 @@
+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