home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / cpmug / cpmug049.ark / SORTI.RAT < prev    next >
Encoding:
Text File  |  1984-04-29  |  2.6 KB  |  90 lines
  1.     PROGRAM SORTT
  2. # Test driver for quick address sort routine SORTI
  3.     DIMENSION INDEX(64),IT(8),KAR(64)
  4. # Random data is best for finding bugs but RAND func not in F-80
  5. #DATA KAR/'AF','GH','FL','XH','EI','RT','AL','SL',
  6. #'RF','YN','SK','RM','SL','WM','QK','WM',
  7. #'FB','DK','FK','WB','EY','QX','ZX','SI',
  8. #'DL','TW','PI','RT','EF','VI','EJ','FY',
  9. #'SG','DG','WJ','RI','PR','EI','WJ','SO',
  10. #'AK','EG','YV','FD','VP','DI','XU','ZP',
  11. #'DF','LC','SV','DW','FW','ST','QF','FE',
  12. #'SH','LQ','WT','CY','VE','WK','XY','AN'/
  13.     WRITE(3,5)
  14. 5    FORMAT(1X,'How many shall we sort?')
  15.     READ(3,10)N
  16. 10    FORMAT(I2)
  17.     DO I=1,N
  18.     KAR(I)=(SIN(FLOAT(I))+1.)*16384.
  19.     CALL SORTI(KAR,INDEX,N)
  20.     WRITE(3,20)
  21. 20    FORMAT(1X,'Indexed test array')
  22.     DO I=1,N,8
  23.     $(DO J=1,8
  24.     $(JI=I+J-1;IXJ=INDEX(JI);IT(J)=KAR(IXJ)$)
  25.     WRITE(3,30)IT $)
  26. 30    FORMAT(8I6)
  27.     STOP
  28.     END
  29. SUBROUTINE SORTI(A,IX,N)
  30. define(MAXM,13)
  31. DIMENSION A(N),IX(N),I(MAXM),L(MAXM)
  32. # IX WILL BE INDEX TO THE N ELEMENTS OF A IN INCREASING ORDER
  33. # This type statement can be changed appropriately
  34. # or a comparison function can be used
  35.     INTEGER A
  36. # INITIALIZE INDEX
  37. DO J=1,N
  38.   IX(J)=J
  39. #ACTUAL MAXIMUM DIMENSION OF I,L IS LOG BASE 2 OF N
  40. M=1
  41. I(1)=1
  42. L(1)=N
  43. REPEAT $(
  44.   IM=I(M)
  45.   J=IM
  46.   K=L(M)+1
  47.   IF(K<J+2) M=M-1
  48. # IF SEGMENT M HAS 0 OR 1 MEMBER
  49.   ELSE $(
  50. # NEARLY SORTED DATA PROCESS FASTER IF IX(J)&IX((K+J)/2)
  51. # ARE INTERCHANGED HERE FIRST
  52. # CHOOSE FIRST ELEMENT AS PIVOT
  53.     IXIM=IX(J)
  54. # SEGMENT M HAS 2 OR MORE MEMBERS - PARTITION INTO 3 SEGMENTS
  55. # BEGIN LOOP 2 - FIND FIRST ENTRY TO BE MOVED TO END
  56.     REPEAT $(J1=J+1;K1=K-1;DO J=J1,K1
  57. # This GOTO can be replaced by BREAK and the next BREAK omitted
  58. # however, this causes the next WHILE to execute unnecessarily
  59.     $(IXJ=IX(J);IF(A(IXIM)<A(IXJ)) GOTO 120$)
  60.       BREAK # IF HERE, DONE PARTIONING
  61. # FIND LAST ENTRY TO BE MOVED TO FRONT (LOOP 3)
  62. # NO NEED TO TEST K IN LOOP SINCE DATA WILL STOP LOOP
  63.       120 REPEAT $(K=K-1
  64.     IXK=IX(K)$)UNTIL (A(IXIM)>=A(IXK))
  65. # SWAP IX(J) & IX(K)
  66.       K=MAX0(K,J)
  67.       IF(K==J)BREAK
  68.       IT=IX(J)
  69.       IX(J)=IX(K)
  70.       IX(K)=IT
  71.       $)# END OF REPEAT LOOP, EXITS AT 2 BREAKS
  72. # PUT FIRST ELEMENT BETWEEN 2 NEW SEGMENTS AT K-1
  73.     IX(IM)=IX(K-1)
  74.     IX(K-1)=IXIM
  75. # LARGER SEGMENT IS NEW SEGMENT M - SIZES ARE K-I(M)-1, L(M)-K+1
  76.     IF(K*2-L(M)-IM<2)#IF TAIL SEGMENT LONGER
  77.     $( I(M+1)=IM
  78.     I(M)=K
  79.     L(M+1)=K-2 $)
  80.     ELSE $(I(M+1)=K
  81.     L(M+1)=L(M)
  82.     L(M)=K-2 $)
  83. # WORK ON SHORT SEGMENT NEXT
  84.     M=M+1
  85.     IF(M>MAXM)WRITE(3,90)
  86.     90 FORMAT(1X,'Number of segments in quicksort exceeds MAXM ')
  87. $) $) UNTIL (M<1 | M>MAXM)
  88. RETURN
  89. END
  90.