Arrays in VBScript sehr schnell sortieren - Mischsort von 1985

Option Explicit

' Mischsort-Algorithmus  
' =====================  
'  
' Original: Zeitschrift "64er" Ausgabe 9/1985, Seite 126/127  
' Originalautor: Horst Armin Kosog  
'  
' C64-Originalprogramm (optisch aufgebessert):  
'1000 DIM A$(6):A=6  
'1010 A$(1)="TEST"  
'1020 A$(2)="TEST2"  
'1030 A$(3)="NOCHEINS"  
'1040 A$(4)="EINELEMENT"  
'1050 A$(5)="NOCHEINELEMENT"  
'1060 A$(6)="LETZTES ELEMENT"  
'10050 ZF=INT(A/2+.5)  
'10052 DIM TV$(ZF)  
'10059 REM  
'10060 FOR X=2 TO A STEP 2  
'10070    IF A$(X-1)>A$(X) THEN TV$(0)=A$(X-1):A$(X-1)=A$(X):A$(X)=TV$(0)  
'10080 NEXT X  
'10082 IF A<3 THEN 50000  
'10090 LF=1  
'10092 FOR MZ=1 TO INT(LOG(A-1)/LOG(2))  
'10100    ZF=INT(ZF/2+.5)  
'10101    LF=2*LF  
'10110    FOR FZ=1 TO ZF  
'10112       A1=1+2*LF*(FZ-1)  
'10114       A2=A1+LF  
'10116       E1=A2-1  
'10118       E2=E1+LF  
'10120       IF E2<=A THEN ET=LF:GOTO 10150  
'10130       IF A<A2 THEN 10230  
'10140       E2=A  
'10142       ET=A+1-A2  
'10150       FOR X=1 TO ET:TV$(X)=A$(X+E1):NEXT  
'10160       FOR X=E2 TO A1 STEP -1  
'10170          IF A$(E1)<TV$(ET) THEN 10200  
'10180          A$(X)=A$(E1)  
'10182          E1=E1-1  
'10184          IF E1>=A1 THEN 10220  
'10190          FOR Y=X-1 TO A1 STEP -1  
'10192             A$(Y)=TV$(ET)  
'10194             ET=ET-1  
'10196          NEXT Y  
'10198          GOTO 10210  
'10200          A$(X)=TV$(ET)  
'10202          ET=ET-1  
'10204          IF ET>=1 THEN 10220  
'10210          X=A1  
'10220       NEXT X  
'10230    NEXT FZ  
'10240 NEXT MZ  
'50000 FOR I=1 TO 6:PRINT A$(I):NEXT I  
'  
'  
' ------------------------------------  
' VBS-Variante  
' ------------------------------------  
' Autor: Christian Coppes  
' Version: 1.0  
' Letzte Änderung: 29.11.2007  
'  
' Die Sortierroutine sortiert extrem schnell auch große Stringmengen.  
' Kleiner Wermutstropfen: Das Stringarray muß mit Index 1 beginnen.  


Const Anz=10

Dim I,strSort(), strAnzeige, strElement
ReDim strSort(Anz)

strSort(1)="Test"  
strSort(2)="Test2"  
strSort(3)="Nocheins"  
strSort(4)="EinElement"  
strSort(5)="Noch ein Element"  
strSort(6)="Letztes Element"  
strSort(7)="Doch nicht1"  
strSort(8)="2Doch nicht"  
strSort(9)="3Nicht doch"  
strSort(10)="Mal sehen, was geht"  

'strSort(1)="6"  
'strSort(2)="4"  
'strSort(3)="1"  
'strSort(4)="3"  
'strSort(5)="9"  
'strSort(6)="5"  
'strSort(7)="8"  
'strSort(8)="7"  
'strSort(9)="0"  
'strSort(10)="2"  

For I = 1 To Anz
	strAnzeige=strAnzeige+strSort(I)+vbCr
Next
MsgBox strAnzeige

Mischsort strSort

strAnzeige=""  
For I = 1 To Anz
	strAnzeige=strAnzeige+strSort(I)+vbCr
Next
MsgBox strAnzeige

WScript.Quit

Function Mischsort(strArr)
	Dim A,intTeilfeldAnzahl,X, intLaufendeFeldlaenge, intMischzaehler, intTeilfeldZaehler
	Dim A1, A2, E1, E2, ET, Y
	Dim ZF, LF, MZ, FZ, NextX
	Dim strTempArr()

	A=UBound(strArr)

	ZF=Int(A/2+0.5)
	ReDim strTempArr(ZF)

	For X=2 To A Step 2
		If strArr(X-1)>strArr(X) Then
			strTempArr(0)=strArr(X-1)
			strArr(X-1)=strArr(X)
			strArr(X)=strTempArr(0)
		End If
	Next 'X  
	If A<3 Then WScript.Quit
	LF=1
	For MZ=1 To Int(Log(A-1)/Log(2))
		ZF=Int(ZF/2+0.5)
		LF=2*LF
		For FZ=1 To ZF
			A1=1+2*LF*(FZ-1)
			A2=A1+LF
			E1=A2-1
			E2=E1+LF
			If E2<=A Then
				ET=LF
			Else
				If Not(A<A2) Then
					E2=A
					ET=A+1-A2
				End If
			End If

			If (E2<=A) Or (Not(A<A2)) Then
				For X=1 To ET
					strTempArr(X)=strArr(X+E1)
				Next
				For X=E2 To A1 Step -1
					NextX=0
					If strArr(E1)<strTempArr(ET) Then
						NextX=1 ' Flag setzen, um "GOTO 10220" zu emulieren  
						strArr(X)=strTempArr(ET)
						ET=ET-1
						If Not(ET>=1) Then
							X=A1
						End If
					End If

					If NextX=0 Then
						strArr(X)=strArr(E1)
						E1=E1-1
						If Not(E1>=A1) Then
							For Y=X-1 To A1 Step -1
								strArr(Y)=strTempArr(ET)
								ET=ET-1
							Next 'Y  
							X=A1
						End If
					End If
				Next 'X  
			End If '(E2<=A) Or (Not(A<A2))  
		Next 'FZ  
	Next 'MZ  
End Function