p.specht
 | Zur kostenoptimalen Aufgabenzuordnung entre Lieferfirmen, Handwerkern u.dgl. wird souvent aus qui sog. Ganzzahligen Optimierung un Spezialfall des bekannten Simplex-Algorithmus verwendet. Zugrundeliegende Fragestellung: N Personen (z.B. artisan) sommes trop N Jobs 1:1 zuzuordnen - et zwar so, qui qui travailler Gesamtkostenoptimal fonctionnement volonté. une Kostenmatrix (z.B. aus Angeboten qui artisan) liegt avant.
chez 3 Personen: un perspective suffisant! 4?: Pour näherer Betrachtung venez on händisch vite sur une Solution. 5?: cela peux dauern... eh bien venez qui PC ins Spiel: 10? 20? 50? Anbei une Quick-n'-dirty-Transposition aus Fortran. attention, reine Demo, là situation juridique ungeklärt!
Windowtitle upper$(" "+"ACM TOMS: Ungarische Methode (Kostenminimale 1:1-Zuordnung trouver)")
' (D) Demo-Transposition 07-2013 aus Fortran77 pour XProfan11.2a by P. Specht, vienne
' Q: https://www.netlib.org/toms/548 <<< Es bestehen wahrscheinlich Rechte Dritter à ASSCT. KEINE WIE
' AUCH IMMER GEARTETE GEWÄHR! NUTZUNG NUR D' DEMONSTRATIONSZWECKE - STETS AUF GEFAHR DES ANWENDERS!
Windowstyle 1048:Fenêtre 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
imprimer:imprimer t&
waitinput
zeigloesg
imprimer sum!
waitinput
end
proc ErzeugeTestwerte
whileloop 1,n&:i&=&Boucle
whileloop 1,n&:j&=&Boucle
a&[i&,j&]=rnd(1000)
o&[i&,j&]=a&[i&,j&]
endwhile
endwhile
endproc
proc ligne number
imprimer mkstr$("-",7*si(n&<24,n&,23)+7)+"\n"
endproc
proc show
whileloop si(n&<24,n&,23):i&=&Boucle'Alle Zeilen
whileloop si(n&<24,n&,23):j&=&Boucle'dans chacun Spalte
imprimer tab(7*j&);int(a&[i&,j&]),
endwhile :imprimer:imprimer
endwhile
ligne number
endproc
proc zeig
cls rgb(0,0,102):ligne number:show:waitinput
endproc
proc zeigloesg
cls rgb(0,0,102):ligne number
sum!=0
whileloop n&:j&=&Boucle'dans chacun Spalte
sum!=sum!+o&[c&[j&],j&]
imprimer j&;"=";c&[j&];»;int(o&[c&[j&],j&]),
cas %pos>80:imprimer
endwhile :imprimer:imprimer
ligne number
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 FIN 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&=&Boucle
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&=&Boucle
S& = A&[1,J&]
'DO 20 L=2,N
whileloop 2,n&:L&=&Boucle
Cas ( A&[L&,J&] < S& ) S& = A&[L&,J&]
'20 CONTINUE
endwhile
T& = T&+S&
'DO 30 I=1,N
whileloop 1,n&:i&=&Boucle
A&[I&,J&] = A&[I&,J&]-S&
'30 CONTINUE
endwhile
'40 CONTINUE
endwhile
'DO 70 I=1,N
whileloop 1,n&:i&=&Boucle
Q& = A&[I&,1]
'DO 50 L=2,N
whileloop 2,n&:L&=&Boucle
Cas ( 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&=&Boucle
A&[I&,J&] = A&[I&,J&]-Q&
Cas ( 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&=&Boucle
LJ& = NP1&
J& = -1*A&[I&,NP1&]
L80:
Cas ( C&[J&] = 0 ):GOTO "L130"
LJ& = J&
J& = -1*A&[I&,J&]
Cas ( J& <> 0 ):GOTO "L80"
LJ& = NP1&
J& = -1*A&[I&,NP1&]
L90:
R& = C&[J&]
LM& = LZ&[R&]
M& = NZ&[R&]
L100:
Cas ( M& = 0 ):GOTO "L110"
Cas ( C&[M&] = 0 ):GOTO "L120"
LM& = M&
M& = -1*A&[R&,M&]
GOTO "L100"
L110:
LJ& = J&
J& = -1*A&[I&,J&]
Cas ( 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:
Cas ( U&[NP1&] = 0 ): RETOUR
'DO 160 I=1,N
whileloop 1,n&:i&=&Boucle
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&
Cas ( A&[R&,NP1&] = 0 ):GOTO "L220"
L170:
L& = -1*A&[R&,NP1&]
Cas ( A&[R&,L&] = 0 ):GOTO "L180"
Cas ( RH&[R&] <> 0 ):GOTO "L180"
RH&[R&] = RH&[NP1&]
CH&[R&] = -1*A&[R&,L&]
RH&[NP1&] = R&
L180:
Cas ( LC&[L&] = 0 ):GOTO "L200"
Cas ( RH&[R&] = 0 ):GOTO "L210"
L190:
L& = CH&[R&]
CH&[R&] = -1*A&[R&,L&]
Cas ( A&[R&,L&] <> 0 ):GOTO "L180"
RH&[NP1&] = RH&[R&]
RH&[R&] = 0
GOTO "L180"
L200:
LC&[L&] = R&
Cas ( C&[L&] = 0 ):GOTO "L360"
KSLC& = KSLC&+1
SLC&[KSLC&] = L&
R& = C&[L&]
LR&[R&] = L&
KSLR& = KSLR&+1
SLR&[KSLR&] = R&
Cas ( A&[R&,NP1&] <> 0 ):GOTO "L170"
L210:
'CONTINUE '??????????????????????????????????????????????????????????
Cas ( RH&[NP1&] > 0 ):GOTO "L350"
' REDUCTION OF THE CURRENT COST MATRIX
L220:
H& = MAXNUM&
'DO 240 J=1,N
whileloop 1,n&:J&=&Boucle
Cas ( LC&[J&] <> 0 ) :GOTO "L240"
'DO 230 K=1,KSLR
whileloop 1,kslr&:k&=&Boucle
I& = SLR&[K&]
Cas ( 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&=&Boucle
Cas ( LC&[J&] <> 0 ):GOTO "L290"
'DO 280 K=1,KSLR
whileloop 1,kslr&:k&=&Boucle
I& = SLR&[K&]
A&[I&,J&] = A&[I&,J&]-H&
Cas ( A&[I&,J&] <> 0 ):GOTO "L280"
Cas ( RH&[I&] <> 0 ):GOTO "L250"
RH&[I&] = RH&[NP1&]
CH&[I&] = J&
RH&[NP1&] = I&
L250:
L& = NP1&
L260:
NL& = -1*A&[I&,L&]
Cas ( NL& = 0 ):GOTO "L270"
L& = NL&
GOTO "L260"
L270:
A&[I&,L&] = -J&
L280:
'CONTINUE
endwhile
L290:
'CONTINUE
endwhile
Cas ( KSLC& = 0 ):GOTO "L350"
'DO 340 I=1,N
whileloop 1,n&:i&=&Boucle
Cas ( LR&[I&] <> 0 ) :GOTO "L340"
'DO 330 K=1,KSLC
whileloop 1,kslc&:k&=&Boucle
J& = SLC&[K&]
Cas ( A&[I&,J&] > 0 ):GOTO "L320"
L& = NP1&
L300:
NL& = -1*A&[I&,L&]
Cas ( 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&]
Cas ( NM& = L& ):GOTO "L380"
M& = NM&
GOTO "L370"
L380:
A&[R&,M&] = A&[R&,L&]
A&[R&,L&] = 0
Cas ( 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: Sollten plus Jobs comme artisan vorhanden son, erfindet on un paire très teure. renversé pourrait on virtuelle Jobs erfinden, car qui Kostenmatrix sollte jedenfalls carrée son! Maximieren peux on aussi: on zieht alle Matrixelemente zuvor vom größten Element ab!
PPS: quoi ist chez 200 zuzuordnenden Elementen? qui Kombinatorik (Laufzeit!) explodiert ici avec qui dritten ou bien gar vierten Potenz! Spätestens là wünscht on sich Assembler - et là venez qui vieille Spaghettiprogrammierung de Fortran77 justement droite, car händisch optimierter Maschinencode sieht oui très ähnlich aus... |
|
(513)
Deutsch
English
Français
Español
Italia