p.specht
 | to kostenoptimalen Aufgabenzuordnung between Lieferfirmen, Handwerkern u.dgl. becomes often from the undertow. Ganzzahligen optimization one Spezialfall the known Simplex-Algorithmus uses. Zugrundeliegende Fragestellung: n Personen (z.B. Handwerker) are To n Jobs 1:1 zuzuordnen - and of course so, that the works Gesamtkostenoptimal carryed out go. an Kostenmatrix (z.B. from offered the Handwerker) lying to.
with 3 Personen: One look sufficient! 4?: After näherer Betrachtung comes one händisch rasch on a Solution. 5?: the can last... now comes PC in that game: 10? 20? 50? enclosed a quick-n'-dirty-Transposition from Fortran. deference, pure demonstration, there legal situation ungeklärt!
Windowtitle upper$(" "+"ACM TOMS: hungarian method (Kostenminimale 1:1-Zuordnung find)")
' (D) demonstration-Transposition 07-2013 from Fortran77 to XProfan11.2a by P. woodpecker, Wien
' Q: https://www.netlib.org/toms/548 <<< it consist probably rights Third on ASSCT. NO WIE
' AUCH IMMER GEARTETE GEWÄHR! NUTZUNG ONLY FOR DEMONSTRATIONSZWECKE - STETS ON GEFAHR DES ANWENDERS!
Windowstyle 1048:Window 0,0-%maxx,%maxy-40:var xm&=width(%hwnd):var ym&=height(%hwnd)
cls rgb(0,0,102):color 14,8:usepen 0,1,rgb(255,255,0):usebrush 1,rgb(255,255,0):randomize
var n&=40
declare A&[130,131], O&[130,131],i&,j&,t&,C&[131],sum!
Main:
ErzeugeTestwerte
zeig
ASSCT(n&,a&[])
zeig
print:print t&
waitinput
zeigloesg
print sum!
waitinput
end
proc ErzeugeTestwerte
whileloop 1,n&:i&=&Loop
whileloop 1,n&:j&=&Loop
a&[i&,j&]=rnd(1000)
o&[i&,j&]=a&[i&,j&]
endwhile
endwhile
endproc
proc line
print mkstr$("-",7*if(n&<24,n&,23)+7)+"\n"
endproc
proc show
whileloop if(n&<24,n&,23):i&=&Loop'any Lines
whileloop if(n&<24,n&,23):j&=&Loop'in eachone slot
print tab(7*j&);int(a&[i&,j&]),
endwhile :print:print
endwhile
line
endproc
proc zeig
cls rgb(0,0,102):line:show:waitinput
endproc
proc zeigloesg
cls rgb(0,0,102):line
sum!=0
whileloop n&:j&=&Loop'in eachone slot
sum!=sum!+o&[c&[j&],j&]
print j&;"=";c&[j&];":";int(o&[c&[j&],j&]),
case %pos>80:print
endwhile :print:print
line
endproc
PROC ASSCT :parameters N&,A&[]
declare CH&[130],LC&[130],LR&[130],LZ&[130],NZ&[130],RH&[131],SLC&[130],SLR&[130],U&[131]
declare H&, Q&, R&, S&, K&, LJ&, LM&, M&, NL&, NM&
' EQUIVALENCE (LZ[],RH[]), (NZ[],CH[])
'
' THIS SUBROUTINE SOLVES THE SQUARE ASSIGNMENT PROBLEM
' THE MEANING OF THE INPUT PARAMETERS IS
' n = NUMBER OF ROWS AND COLUMNS OF THE COST MATRIX, WITH
' THE CURRENT DIMENSIONS THE MAXIMUM VALUE OF n IS 130
' A(I,J) = ELEMENT IN ROW I AND COLUMN J OF THE COST MATRIX
' ( AT THE END OF COMPUTATION THE ELEMENTS OF A ARE CHANGED)
' THE MEANING OF THE OUTPUT PARAMETERS IS
' C(J) = ROW ASSIGNED TO COLUMN J (J=1,n)
' T = COST OF THE OPTIMAL ASSIGNMENT
' ALL PARAMETERS ARE INTEGER
' THE MEANING OF THE LOCAL VARIABLES IS
' A(I,J) = ELEMENT OF THE COST MATRIX IF A(I,J) IS POSITIVE,
' COLUMN OF THE UNASSIGNED ZERO FOLLOWING IN ROW I
' (I=1,n) THE UNASSIGNED ZERO OF COLUMN J (J=1,n)
' IF A(I,J) IS NOT POSITIVE
' A(I,n+1) = COLUMN OF THE FIRST UNASSIGNED ZERO OF ROW I
' (I=1,n)
' CH(I) = COLUMN OF THE NEXT UNEXPLORED AND UNASSIGNED ZERO
' OF ROW I (I=1,n)
' LC(J) = LABEL OF COLUMN J (J=1,n)
' LR(I) = LABEL OF ROW I (I=1,n)
' LZ(I) = COLUMN OF THE LAST UNASSIGNED ZERO OF ROW I(I=1,n)
' NZ(I) = COLUMN OF THE NEXT UNASSIGNED ZERO OF ROW I(I=1,n)
' RH(I) = UNEXPLORED ROW FOLLOWING THE UNEXPLORED ROW I
' (I=1,n)
' RH(n+1) = FIRST UNEXPLORED ROW
' SLC(k) = k-TH ELEMENT CONTAINED IN THE SET OF THE LABELLED
' COLUMNS
' SLR(k) = k-TH ELEMENT CONTAINED IN THE SET OF THE LABELLED
' ROWS
' u(I) = UNASSIGNED ROW FOLLOWING THE UNASSIGNED ROW I
' (I=1,n)
' u(n+1) = FIRST UNASSIGNED ROW
'
' THE VECTORS C,CH,LC,LR,LZ,NZ,SLC,SLR MUST BE DIMENSIONED
' AT LEAST AT (n), THE VECTORS RH,u AT LEAST AT (n+1),
' THE MATRIX A AT LEAST AT (n,n+1)
'
' INITIALIZATION
declare maxnum&,np1&,J&,I&,L&,KSLC&,KSLR&
MAXNUM& = 2^31-1
NP1& = N&+1
' DO 10 J=1,n
whileloop 1,n&:J&=&Loop
C&[J&] = 0
LZ&[J&] = 0
NZ&[J&] = 0
U&[J&] = 0
'10 CONTINUE
endwhile
U&[NP1&] = 0
T& = 0
' REDUCTION OF THE INITIAL COST MATRIX
'DO 40 J=1,n
whileloop 1,n&:J&=&Loop
S& = A&[1,J&]
'DO 20 L=2,n
whileloop 2,n&:L&=&Loop
Case ( A&[L&,J&] < S& ) S& = A&[L&,J&]
'20 CONTINUE
endwhile
T& = T&+S&
'DO 30 I=1,n
whileloop 1,n&:i&=&Loop
A&[I&,J&] = A&[I&,J&]-S&
'30 CONTINUE
endwhile
'40 CONTINUE
endwhile
'DO 70 I=1,n
whileloop 1,n&:i&=&Loop
Q& = A&[I&,1]
'DO 50 L=2,n
whileloop 2,n&:L&=&Loop
Case ( A&[I&,L&] < Q& ):Q& = A&[I&,L&]
'50 CONTINUE
endwhile
T& = T&+Q&
L& = NP1&
'DO 60 J=1,n
whileloop 1,n&:J&=&Loop
A&[I&,J&] = A&[I&,J&]-Q&
Case ( A&[I&,J&] <> 0 ):GOTO "L60"
A&[I&,L&] = -J&
L& = J&
L60:
'CONTINUE
endwhile
'70 CONTINUE
endwhile
' CHOICE OF THE INITIAL SOLUTION
K& = NP1&
'DO 140 I=1,n
whileloop 1,n&:i&=&Loop
LJ& = NP1&
J& = -1*A&[I&,NP1&]
L80:
Case ( C&[J&] = 0 ):GOTO "L130"
LJ& = J&
J& = -1*A&[I&,J&]
Case ( J& <> 0 ):GOTO "L80"
LJ& = NP1&
J& = -1*A&[I&,NP1&]
L90:
R& = C&[J&]
LM& = LZ&[R&]
M& = NZ&[R&]
L100:
Case ( M& = 0 ):GOTO "L110"
Case ( C&[M&] = 0 ):GOTO "L120"
LM& = M&
M& = -1*A&[R&,M&]
GOTO "L100"
L110:
LJ& = J&
J& = -1*A&[I&,J&]
Case ( J& <> 0 ):GOTO "L90"
U&[K&] = I&
K& = I&
GOTO "L140"
L120:
NZ&[R&] = -1*A&[R&,M&]
LZ&[R&] = J&
A&[R&,LM&] = -J&
A&[R&,J&] = A&[R&,M&]
A&[R&,M&] = 0
C&[M&] = R&
L130:
C&[J&] = I&
A&[I&,LJ&] = A&[I&,J&]
NZ&[I&] = -1*A&[I&,J&]
LZ&[I&] = LJ&
A&[I&,J&] = 0
L140:
'140 CONTINUE
endwhile
' RESEARCH OF A NEW ASSIGNMENT
L150:
Case ( U&[NP1&] = 0 ): RETURN
'DO 160 I=1,n
whileloop 1,n&:i&=&Loop
CH&[I&] = 0
LC&[I&] = 0
LR&[I&] = 0
RH&[I&] = 0
'160 CONTINUE
endwhile
RH&[NP1&] = -1
KSLC& = 0
KSLR& = 1
R& = U&[NP1&]
LR&[R&] = -1
SLR&[1] = R&
Case ( A&[R&,NP1&] = 0 ):GOTO "L220"
L170:
L& = -1*A&[R&,NP1&]
Case ( A&[R&,L&] = 0 ):GOTO "L180"
Case ( RH&[R&] <> 0 ):GOTO "L180"
RH&[R&] = RH&[NP1&]
CH&[R&] = -1*A&[R&,L&]
RH&[NP1&] = R&
L180:
Case ( LC&[L&] = 0 ):GOTO "L200"
Case ( RH&[R&] = 0 ):GOTO "L210"
L190:
L& = CH&[R&]
CH&[R&] = -1*A&[R&,L&]
Case ( A&[R&,L&] <> 0 ):GOTO "L180"
RH&[NP1&] = RH&[R&]
RH&[R&] = 0
GOTO "L180"
L200:
LC&[L&] = R&
Case ( C&[L&] = 0 ):GOTO "L360"
KSLC& = KSLC&+1
SLC&[KSLC&] = L&
R& = C&[L&]
LR&[R&] = L&
KSLR& = KSLR&+1
SLR&[KSLR&] = R&
Case ( A&[R&,NP1&] <> 0 ):GOTO "L170"
L210:
'CONTINUE '??????????????????????????????????????????????????????????
Case ( RH&[NP1&] > 0 ):GOTO "L350"
' REDUCTION OF THE CURRENT COST MATRIX
L220:
H& = MAXNUM&
'DO 240 J=1,n
whileloop 1,n&:J&=&Loop
Case ( LC&[J&] <> 0 ) :GOTO "L240"
'DO 230 K=1,KSLR
whileloop 1,kslr&:k&=&Loop
I& = SLR&[K&]
Case ( A&[I&,J&] < H& ): H& = A&[I&,J&]
'230 CONTINUE
endwhile
L240:
'CONTINUE
endwhile
T& = T&+H&
'DO 290 J=1,n
whileloop 1,n&:J&=&Loop
Case ( LC&[J&] <> 0 ):GOTO "L290"
'DO 280 K=1,KSLR
whileloop 1,kslr&:k&=&Loop
I& = SLR&[K&]
A&[I&,J&] = A&[I&,J&]-H&
Case ( A&[I&,J&] <> 0 ):GOTO "L280"
Case ( RH&[I&] <> 0 ):GOTO "L250"
RH&[I&] = RH&[NP1&]
CH&[I&] = J&
RH&[NP1&] = I&
L250:
L& = NP1&
L260:
NL& = -1*A&[I&,L&]
Case ( NL& = 0 ):GOTO "L270"
L& = NL&
GOTO "L260"
L270:
A&[I&,L&] = -J&
L280:
'CONTINUE
endwhile
L290:
'CONTINUE
endwhile
Case ( KSLC& = 0 ):GOTO "L350"
'DO 340 I=1,n
whileloop 1,n&:i&=&Loop
Case ( LR&[I&] <> 0 ) :GOTO "L340"
'DO 330 K=1,KSLC
whileloop 1,kslc&:k&=&Loop
J& = SLC&[K&]
Case ( A&[I&,J&] > 0 ):GOTO "L320"
L& = NP1&
L300:
NL& = -1*A&[I&,L&]
Case ( NL& = J& ):GOTO "L310"
L& = NL&
GOTO "L300"
L310:
A&[I&,L&] = A&[I&,J&]
A&[I&,J&] = H&
GOTO "L330"
L320:
A&[I&,J&] = A&[I&,J&]+H&
L330:
'CONTINUE
endwhile
L340:
'CONTINUE
endwhile
L350:
R& = RH&[NP1&]
GOTO "L190"
' ASSIGNMENT OF A NEW ROW
L360:
C&[L&] = R&
M& = NP1&
L370:
NM& = -1*A&[R&,M&]
Case ( NM& = L& ):GOTO "L380"
M& = NM&
GOTO "L370"
L380:
A&[R&,M&] = A&[R&,L&]
A&[R&,L&] = 0
Case ( LR&[R&] < 0 ):GOTO "L390"
L& = LR&[R&]
A&[R&,L&] = A&[R&,NP1&]
A&[R&,NP1&] = -L&
R& = LC&[L&]
GOTO "L360"
L390:
U&[NP1&] = U&[R&]
U&[R&] = 0
GOTO "L150"
ENDPROC
P.s: should More Jobs as Handwerker present his, erfindet one a couple very teure. inverse could one virtual Jobs invent, because The Kostenmatrix ought to anyway quadratic his! maximize can too: one zieht any Matrixelemente before of biggest element ex!
PPS: What is with 200 zuzuordnenden Elementen? The Kombinatorik (Laufzeit!) explode here with the third or quite fourth Potenz! At the latest there wish one itself Assembler - and there comes The old Spaghettiprogrammierung of Fortran77 straight right, because händisch optimierter Maschinencode sees Yes very similar from... |
|
(701)
Deutsch
English
Français
Español
Italia