XProfan

WindowTitle upper$("Singleton-Sort eines Integer-Vektors zwischen Index ii und jj")
' (D) DEMO TRANSLATION from Fortran77 to XProfan11.2a in 2014-11
' by P. Specht, Wien (Austria); Ohne jedwede Gewähr! No warranties whatsoever!
'*******************************************************************************
' An Efficient Algorithm for Sorting with Minimal Storage, by: R. C. Singleton
' ALGORITHM 347, COLLECTED ALGORITHMS FROM ACM.
' THIS WORK PUBLISHED IN COMMUNICATIONS OF THE ACM
' VOL. 12, NO. 3, March, 1969, PP.185--187.
'*******************************************************************************
' SORTS ARRAY A INTO INCREASING ORDER, FROM A(II) TO A(JJ).
' ORDERING IS BY ***INTEGER SUBTRACTION***, THUS FLOATING POINT
' NUMBERS MUST BE IN NORMALIZED FORM!
' ARRAYS IU(K) AND IL(K) PERMIT SORTING UP TO 2^(K+1)-1 ELEMENTS.
'*******************************************************************************
WindowStyle 24:font 2
Window 0,0-%maxx,%maxy

Proc SingletonSORT :parameters A&[],ii&,jj&

    DECLARE iJ&,il&[16],iu&[16],j&,k&,l&,m&,t&,tt&
    M& = 1
    I& = II&
    J& = JJ&
    G5:
    CASE I& >= J&: GOTO "G70"
    G10:
    K& = I&
    IJ& = (J&+I&)/2
    T& = A&[IJ&]
    case A&[I&]<=T&:GOTO "G20"
    A&[IJ&] = A&[I&]
    A&[I&] = T&
    T& = A&[IJ&]
    G20:
    L& = J&
    case A&[J&] >= T& : GOTO "G40"
    A&[IJ&] = A&[J&]
    A&[J&] = T&
    T& = A&[IJ&]
    case A&[I&] <= T& : GOTO "G40"
    A&[IJ&] = A&[I&]
    A&[I&] = T&
    T& = A&[IJ&]
    GOTO "G40"
    G30:
    A&[L&] = A&[K&]
    A&[K&] = TT&
    G40:
    L& = L& - 1
    case A&[L&] > T& : GOTO "G40"
    TT& = A&[L&]
    G50:
    K& = K& + 1
    case A&[K&] < T& : GOTO "G50"
    case K& <= L&: GOTO "G30"
    case (L&-I&) <= (J&-K&): GOTO "G60"
    IL&[M&] = I&
    IU&[M&] = L&
    I& = K&
    M& = M& + 1
    GOTO "G80"
    G60:
    IL&[M&] = K&
    IU&[M&] = J&
    J& = L&
    M& = M& + 1
    GOTO "G80"
    G70:
    M& = M& - 1
    case M& = 0 : RETURN
    I& = IL&[M&]
    J& = IU&[M&]
    G80:
    case (J&-I&) >= II& : GOTO "G10"
    case I& = II& : GOTO "G5"
    I& = I& - 1
    G90:
    I& = I& + 1
    case I& = J& : GOTO "G70"
    T& = A&[I&+1]
    case A&[I&] <= T& : GOTO "G90"
    K& = I&
    G100:
    A&[K&+1] = A&[K&]
    K& = K& - 1
    case T& < A&[K&] : GOTO "G100"
    A&[K&+1] = T&
    GOTO "G90"

endproc

Proc RN' uses seed&

    declare k&,rn! : case seed&=0:seed=rnd()
    '*******************************************************************************
    '  RN returns a unit single precision pseudorandom number.
    '*******************************************************************************
    '
    '  This routine implements the recursion
    '
    '      seed = 16807 * seed mod ( 2^31 - 1 )
    '      rn = seed / ( 2**31 - 1 )
    '
    '    The integer arithmetic never requires more than 32 bits, including a sign bit.
    '
    '    If the initial seed is 12345, then the first three computations are
    '
    '      Input     Output      RN
    '      SEED      SEED
    '
    '         12345   207482415  0.096616
    '     207482415  1790989824  0.833995
    '    1790989824  2035175616  0.947702
    '
    '  Modified: 11 August 2004, Author: John Burkardt
    '
    '  Reference:
    '
    '    Paul Bratley, Bennett Fox, L E Schrage,
    '    A Guide to Simulation,
    '    Springer Verlag, pages 201-202, 1983.
    '
    '    Pierre L'Ecuyer,
    '    Random Number Generation,
    '    in: Handbook of Simulation,
    '    edited by Jerry Banks,
    '    Wiley Interscience, page 95, 1998.
    '
    '    Bennett Fox,
    '    Algorithm 647:
    '    Implementation and Relative Efficiency of Quasirandom
    '    Sequence Generators,
    '    ACM Transactions on Mathematical Software,
    '    Volume 12, Number 4, pages 362-376, 1986.
    '
    '    P A Lewis, A S Goodman, J M Miller,
    '    A Pseudo-Random Number Generator for the System/360,
    '    IBM Systems Journal,
    '    Volume 8, pages 136-143, 1969.
    '
    '  Parameters:
    '
    '    Input/output, integer SEED, the "seed" value, which should NOT be 0.
    '    On output, SEED has been updated.
    '
    '    Output, real RN, a new pseudorandom variate,
    '    strictly between 0 and 1.
    '
    k& = seed& \ 127773
    seed& = 16807 * ( seed& - k& * 127773 ) - k& * 2836

    if seed& < 0

        seed& = seed& + 2147483647

    endif

    '  Although SEED can be represented exactly as a 32 bit integer,
    '  it generally cannot be represented exactly as a 32 bit real number'
    rn! = seed& * val("4.656612875E-10")
    return rn!

endproc

' MAIN tests SORT.
' Modified 04 January 2006 by John Burkardt
Print "\n\n TOMS347_PRB\n Test Singleton Sort, which sorts an integer vector ascending."
declare ii&,jj&
ii& = 1
jj& = 20
test01(ii&,jj&)
waitinput
ii& = 5
jj& = 18
test01(ii&,jj&)
print "\n TOMS347_PRB: Success - Normal end of execution!"
waitinput
end

Proc test01 :parameters ii&,jj&

    '*******************************************************************************
    '  TEST01 tests SORT on a particular range of indices.
    '  Modified 04 January 2006 by John Burkardt
    '*******************************************************************************
    var n&=20
    declare a&[n&],i&,rn!,seed&
    Print "\n\n TEST01: Ascending sorts an integer vector."
    Print " Here we sort entries II = ";ii&;" to JJ = ";jj&
    seed& = 123456789

    whileloop n& : i&=&Loop

        a&[i&] = int(n&*RN(seed&))

    endwhile

    Print "\n Unsorted array:"

    whileloop n&:i&=&Loop

        print i&, a&[i&]

    endwhile

    SingletonSORT(a&[],ii&,jj&)
    Print "\n Sorted array:"

    whileloop n&:i&=&Loop

        print i&, a&[i&]

    endwhile

endproc

''TOMS347_PRB  RESULTS OF Test SORT, which ascending sorts an integer vector.
'
'TEST01
'  SORT ascending sorts an integer vector.
'  Here we sort entries II =      1
'  through JJ =     20
'
'  Unsorted array:
'
'       1       4
'       2      19
'       3      16
'       4      11
'       5       8
'       6       1
'       7       5
'       8       2
'       9       0
'      10      12
'      11       1
'      12       8
'      13       8
'      14      15
'      15      15
'      16       0
'      17      17
'      18       7
'      19       1
'      20       0
'
'  Sorted array:
'
'       1       0
'       2       0
'       3       0
'       4       1
'       5       1
'       6       1
'       7       2
'       8       4
'       9       5
'      10       7
'      11       8
'      12       8
'      13       8
'      14      11
'      15      12
'      16      15
'      17      15
'      18      16
'      19      17
'      20      19
'
'TEST01
'  SORT ascending sorts an integer vector.
'  Here we sort entries II =      5
'  through JJ =     18
'
'  Unsorted array:
'
'       1       4
'       2      19
'       3      16
'       4      11
'       5       8
'       6       1
'       7       5
'       8       2
'       9       0
'      10      12
'      11       1
'      12       8
'      13       8
'      14      15
'      15      15
'      16       0
'      17      17
'      18       7
'      19       1
'      20       0
'
'  Sorted array:
'
'       1       4
'       2      19
'       3      16
'       4      11
'       5       0
'       6       0
'       7       1
'       8       1
'       9       2
'      10       5
'      11       7
'      12       8
'      13       8
'      14       8
'      15      12
'      16      15
'      17      15
'      18      17
'      19       1
'      20       0