' The following are Bubble Sort, Shell-Metzner Sort, and Quicksort
' routines written for Microsoft BASIC (Visual Basic, DOS, etc.).
'
' Each routine has two functions: for zero-based index arrays
' and for one-based index arrays.  These routines were coded
' for single-precision floating-point values, but they can be
' altered to work with any variable type, including variants.

' The following 4 lines are specific to BASIC for DOS;
' use individual DIM statements in Visual Basic code.

defdbl d
defsng f
defint i
deflng l

dim fval(1399)
itot = 1399

' Message: "Sorting one-based index list"
for i = 1 to itot
   fval(i) = rnd * 10
next
i = sortdata(fval(), itot)

' Message: "Sorting zero-based index list"
for i = 0 to itot - 1
   fval(i) = fval(i + 1)
next
i = sortdata2(fval(), itot)

end

'******************************************************************************
' BUBLSORT.BAS
'******************************************************************************

'*******************************************************
'Note: The following is the complete bubble sort routine
'*******************************************************
function sortdata(fval(), itot)
   for ilap = 1 to itot - 1
      for itap = ilap + 1 to itot
         if fval(ilap) > fval(itap) then
            swap fval(ilap), fval(itap)
         end if
      next
   next
end function

'**********************************************************************
'Note: sortdata2 is same as sortdata, but sorts zero-based-index arrays
'      itot is the total of elements, not the upper bound of the array
'**********************************************************************
function sortdata2(fval(), itot)
   for ilap = 0 to itot - 2
      for itap = ilap + 1 to itot - 1
         if fval(ilap) > fval(itap) then
            swap fval(ilap), fval(itap)
         end if
      next
   next
end function

'******************************************************************************
' SHELSORT.BAS
'******************************************************************************

'******************************************************
'Note: The following is the complete Shell sort routine
'******************************************************
function sortdata(fval(), itot)
   irdx = itot \ 2
   while irdx > 0
      for itap = irdx to itot - 1
         for ilap = (itap - irdx + 1) to 1 step -irdx
            if fval(ilap) > fval(ilap + irdx) then
               swap fval(ilap), fval(ilap + irdx)
            else
               exit for
            end if
         next
      next
      irdx = irdx \ 2
   wend
end function

'**********************************************************************
'Note: sortdata2 is same as sortdata, but sorts zero-based-index arrays
'      itot is the total of elements, not the upper bound of the array
'**********************************************************************
function sortdata2(fval(), itot)
   irdx = itot \ 2
   while irdx > 0
      for itap = irdx - 1 to itot - 2
         for ilap = (itap - irdx + 1) to 0 step -irdx
            if fval(ilap) > fval(ilap + irdx) then
               swap fval(ilap), fval(ilap + irdx)
            else
               exit for
            end if
         next
      next
      irdx = irdx \ 2
   wend
end function

'******************************************************************************
' QUIKSORT.BAS
'******************************************************************************

'*****************************************************
'Note: The following is the complete Quicksort routine
'*****************************************************
function sortdata(fval(), istk(), itot)
   irdx = 1
   istk(1) = 1
   istk(2) = itot
   while irdx > 0
      irdx = irdx - 1
      ilsp = istk(irdx + irdx + 1)
      itsp = istk(irdx + irdx + 2)
      fsav = fval(ilsp)
      itap = itsp + 1
      ilap = ilsp
      iex1 = 0
      while not iex1
         itap = itap - 1
         if itap = ilap then
            iex1 = not 0
         elseif fsav > fval(itap) then
            fval(ilap) = fval(itap)
            iex2 = 0
            while not iex2
               ilap = ilap + 1
               if itap = ilap then
                  iex1 = not 0
                  iex2 = not 0
               elseif fsav < fval(ilap) then
                  fval(itap) = fval(ilap)
                  iex2 = not 0
               end if
            wend
         end if
      wend
      fval(ilap) = fsav
      if itsp - ilap > 1 then
         istk(irdx + irdx + 1) = ilap + 1
         istk(irdx + irdx + 2) = itsp
         irdx = irdx + 1
      end if
      if itap - ilsp > 1 then
         istk(irdx + irdx + 1) = ilsp
         istk(irdx + irdx + 2) = itap - 1
         irdx = irdx + 1
      end if
   wend
end function

'**********************************************************************
'Note: sortdata2 is same as sortdata, but sorts zero-based-index arrays
'      itot is the total of elements, not the upper bound of the array
'**********************************************************************
function sortdata2(fval(), istk(), itot)
   irdx = 0
   istk(0) = 0
   istk(1) = itot - 1
   while irdx >= 0
      ilsp = istk(irdx + irdx)
      itsp = istk(irdx + irdx + 1)
      irdx = irdx - 1
      fsav = fval(ilsp)
      ilap = ilsp
      itap = itsp + 1
      iex1 = 0
      while not iex1
         itap = itap - 1
         if itap = ilap then
            iex1 = not 0
         elseif fsav > fval(itap) then
            fval(ilap) = fval(itap)
            iex2 = 0
            while not iex2
               ilap = ilap + 1
               if itap = ilap then
                  iex1 = not 0
                  iex2 = not 0
               elseif fsav < fval(ilap) then
                  fval(itap) = fval(ilap)
                  iex2 = not 0
               end if
            wend
         end if
      wend
      fval(ilap) = fsav
      if itsp - ilap > 1 then
         irdx = irdx + 1
         istk(irdx + irdx) = ilap + 1
         istk(irdx + irdx + 1) = itsp
      end if
      if itap - ilsp > 1 then
         irdx = irdx + 1
         istk(irdx + irdx) = ilsp
         istk(irdx + irdx + 1) = itap - 1
      end if
   wend
end function

'***********************************************************************
'Note: Following routine is provided for compatibility with Visual Basic
'***********************************************************************

sub swap(fval1 as single, fval2 as single)
   static ftemp as single
   ftemp = fval1
   fval1 = fval2
   fval2 = ftemp
end sub
