XProfan

Windowtitle upper$("  "+"ACM TOMS: Ungarische Methode (Kostenminimale 1:1-Zuordnung finden)")
' (D) Demo-Transposition 07-2013 aus Fortran77 nach XProfan11.2a by P. Specht, Wien
' Q: https://www.netlib.org/toms/548   <<< Es bestehen wahrscheinlich Rechte Dritter an ASSCT. KEINE WIE
' AUCH IMMER GEARTETE GEWÄHR! NUTZUNG NUR FÜR DEMONSTRATIONSZWECKE - STETS AUF 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 linie

    print mkstr$("-",7*if(n&<24,n&,23)+7)+"\n"

endproc

proc show

    whileloop if(n&<24,n&,23):i&=&Loop'Alle Zeilen

        whileloop if(n&<24,n&,23):j&=&Loop'in jeder Spalte

            print tab(7*j&);int(a&[i&,j&]),
            endwhile :print:print

        endwhile

        linie

    endproc

    proc zeig

        cls rgb(0,0,102):linie:show:waitinput

    endproc

    proc zeigloesg

        cls rgb(0,0,102):linie
        sum!=0

        whileloop n&:j&=&Loop'in jeder Spalte

            sum!=sum!+o&[c&[j&],j&]
            print j&;"=";c&[j&];":";int(o&[c&[j&],j&]),
            case %pos>80:print
            endwhile :print:print
            linie

        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