XProfan

Titre de la fenêtre "    LINEARE OPTIMIERUNG MITTELS SIMPLEX-ALGORITHMUS  "
'Engl. Original source dans Fortran-77 by John H Matthews 1986-04
'translated to XProfan-11.2a free/German by p.specht 2021-05
'Experimental DEMO only, no warranties whatsoever! aucun Gewähr!
Fenêtre Style 24:font 2:randomize:set("decimals",17)
var co&=rgb(200+rnd(56),200+rnd(56),200+rnd(56))
Fenêtre 0,0-%maxx,%maxy-40:CLS co&
declare i&,j&,k&,MMAX&,NMAX&,M&,M1&,M2&,M3&,F$,F1$,mm&,kp&,bmax!
declare icase&,n&,EPS!,R!,nl1&,nl2&,ir&,q1!,iafb&,kk&,ii&,iabf&
declare test!,ip&,q!,qp!,q0!,i1&,k1&,PIV!,kh&,iis&,M12&,ente&
MMAX& = 25 : NMAX& = 25
declare A![MMAX&,NMAX&],iposv&[MMAX&],izrov&[NMAX&]
PRINT
PRINT " Anzahl Variablen qui Zielfunktion: "; : INPUT N&
PRINT " (Nichtnegativitätsbedingungen volonté automatisch erzeugt!)\n"
PRINT " Nombre de <= (Kapazitätsgrenzen): "; : INPUT M1&
PRINT " Nombre de >= (Mindestauslastung): "; : INPUT M2&
PRINT " Nombre de ==      (Fixsetzungen): "; : INPUT M3&
PRINT
M& = M1& + M2& + M3&'Total number of constraints
F$  = " ########0.0###############;-########0.0###############;        0.0"'"%g"
F1$ = " ########0.0###############;-########0.0###############;        0.0"'"%g"

whileloop M&+2:i&=&Boucle

    whileloop N&+1:j&=&Boucle

        A![i&,j&]=0.0

    endwhile

endwhile

PRINT "\n Eingabe qui Zielfunktion "
imprimer " (Maximiert avec positiven Zielkoeffizienten, minimiert avec Negativen!)\n"

whileloop 2,n&+1:i&=&Boucle

    PRINT " Koeffizient "; int(i&-1); ": ";:INPUT A![1,i&]

endwhile

PRINT " Vorkonstante [meist 0]: ";:INPUT A![1,1]
PRINT:imprimer "\n Beachte qui Reihenfolge qui Ungleichungen: <=, >=, ==\n"

whileloop m&:i&=&Boucle

    PRINT " Eingabe qui Ungleichung Nr."; i&; »

    whileloop 2,n&+1:j&=&Boucle

        PRINT " Koeffizient "; int(j& - 1); ": ";:INPUT R!
        A![i&+1,j&] = -1*R!

    endwhile

    PRINT " Zugehöriger Grenzwert: ";:INPUT A![i&+1,1]
    imprimer

endwhile

PRINT
CLS co&
'  PRINT " Kontroll-Tableau: ":imprimer
'  whileloop m&+1:i&=&Loop
'    whileloop n&+1:j&=&Loop
'      imprimer tab((j&-1)*27);A![i&,j&];
'    endwhile
'    PRINT
'  endwhile
imprimer
GOSUB S1000"'call simplx(A,M,N,M1,M2,M3,ICASE,IZROV,IPOSV)

IF icase& = 0'result ok.

    PRINT
    PRINT " maximum qui Zielfunktion = ";
    PRINT format$(F1$, A![1,1])
    ente&=0

    whileloop n&:i&=&Boucle

        whileloop m&:j&=&Boucle

            IF iposv&[j&] = i&

                PRINT " Optimales X";i&;" = ";format$(F1$,A![j&+1,1])
                ente&=1:pause

            ENDIF

        endwhile

        ifnot ente&

            PRINT "  X";i&;" = ";format$(F1$,0.0)
            ente&=0

        endif

    endwhile

ELSE

    PRINT " aucun Solution trouvé (Fehlercode = "; icase&; ")."

ENDIF

waitinput
FIN
'  Simplex Algorithmus
S1000:
' simplx(A[1..,1.. ], m, n, m1, m2, m3, icase, izrov, iposv)
Déclarer l1&[MMAX&],l2&[MMAX&],l3&[MMAX&]
EPS!=0.000001'<<<<<<<< Adaptieren à verwendete Größenordnungen!

IF M& <> (M1& + M2& + M3&)

    PRINT " salde bains input constraint counts dans simplx."
    RETOUR

ENDIF

nl1& = N&

whileloop n&:k&=&Boucle

    l1&[k&] = k&
    izrov&[k&] = k&

endwhile

nl2& = M&

whileloop m&:i&=&Boucle

    IF A![i&+1,1] < 0.0

        PRINT " salde bains input tableau dans simplx, Constants b_i must être nonnegative."
        RETOUR

    ENDIF

    l2&[i&] = i&
    iposv&[i&] = N& + i&

endwhile

whileloop m2&:i&=&Boucle

    l3&[i&] = 1

endwhile

ir& = 0
cas (M2& + M3&) = 0 : GOTO "G30"
ir& = 1

whileloop n&+1:k&=&Boucle

    q1!=0.0

    whileloop M1&+1,M&:i&=&Boucle

        q1!=q1!+A![i&+1,k&]

    endwhile

    A![M&+2,k&]= -1*q1!

endwhile

G10:
iabf&=0 : mm&=M&+1
GOSUB S2000"'simp1(a,m+1,l1,nl1,0,kp,bmax)

IF (bmax! <= EPS!) AND (A![M&+2,1] < (-1*EPS!))

    icase& = -1  :imprimer " Auxiliary objective function is still negative and can’t être improved! No feasible solution exists."
    RETOUR

ELSEIF (bmax! <= EPS!) AND (A![M&+2,1] <= EPS!)

    m12& = M1& + M2& + 1

    IF m12& <= M&'THEN

        whileloop m12&,m&:ip&=&Boucle

            IF iposv&[ip&] = ip& + N&

                iabf& = 1: mm& = ip&
                GOSUB S2000"'simp1(a,ip,l1,nl1,1,kp,bmax)
                cas bmax! > EPS!:GOTO "G1"

            ENDIF

        endwhile

    ENDIF

    ir& = 0
    m12& = m12& - 1
    cas (M1&+1) > m12& :GOTO "G30"

    whileloop m1&+1,M1&+M2&

        IF l3&[i& - M1&]=1

            whileloop n&+1:k&=&Boucle

                A![i&+1,k&] = -1.0*A![i&+1,k&]

            endwhile

        ENDIF

    endwhile

    GOTO "G30"'Go phase two.

ENDIF

GOSUB S2100"'call simp2(a,m,n,l2,nl2,ip,kp,q1)

IF ip& = 0

    icase& = -1 :imprimer " sans Grenzen: Es existiert aucun ermittelbare konkrete Solution!"
    RETOUR

ENDIF

G1:
i1&=M&+1:k1&=N&
GOSUB S2200"'call simp3(a,m+1,n,ip,kp)

IF iposv&[ip&] >= (N&+M1&+M2&+1)

    whileloop nl1&:k&=&Boucle

        cas l1&[k&] = kp& : GOTO "G2"

    endwhile

    G2:
    nl1& = nl1& - 1

    whileloop k&, nl1& : iis&=&Boucle

        l1&[iis&] = l1&[iis&+1]

    endwhile

ELSE

    cas iposv&[ip&]<(N&+M1&+1):GOTO "G20"
    kh& = iposv&[ip&]-M1&-N&
    cas l3&[kh&] = 0 : GOTO "G20"
    l3&[kh&] = 0

ENDIF

A![M&+2,kp&+1]=A![M&+2,kp&+1]+1.0

whileloop m&+2:i&=&Boucle

    A![i&,kp&+1] = -1.0*A![i&,kp&+1]

endwhile

G20:
iis& = izrov&[kp&]
izrov&[kp&] = iposv&[ip&]
iposv&[ip&] = iis&
cas ir& <> 0 : GOTO "G10"
G30:
iabf& = 0 : mm& = 0
GOSUB S2000"'call simp1(a,0,l1,nl1,0,kp,bmax)

IF bmax! <= EPS!

    icase& = 0
    RETOUR

ENDIF

GOSUB S2100"'call simp2(a,m,n,l2,nl2,ip,kp,q1)

IF ip& = 0 :Imprimer " qui Zielfunktion ist illimité!"

    icase& = 1
    RETOUR

ENDIF

i1& = M& : k1& = N&
GOSUB S2200"'call simp3(a,m,n,ip,kp)
GOTO "G20"
RETOUR
S2000:
' Subroutine simp1(a, mm, l1, nl1, iabf, kp, bmax)
kp& = l1&[1]
bmax! = A![mm&+1,kp&+1]
cas nl1&<2:RETOUR

whileloop 2,nl1&:k&=&Boucle

    IF iabf& = 0'THEN

        test! = A![mm&+1,l1&[k&]+1]-bmax!

    ELSE

        test! = ABS(A![mm&+1,l1&[k&]+1]) - ABS(bmax!)

    ENDIF

    IF test! > 0'THEN

        bmax! = A![mm&+1,l1&[k&]+1]
        kp& = l1&[k&]

    ENDIF

endwhile

RETOUR
S2100:
'Subroutine simp2(a, m, n, l2, nl2, ip, kp, q1)
EPS! = 0.000001
ip& = 0
cas nl2& < 1 : RETOUR

whileloop nl2&:i&=&Boucle

    cas A![i&+1,kp&+1] < (-1*EPS!) : GOTO "G2102"

endwhile

RETOUR'No possible pivots. Retour with message.
G2102:
q1! = -1*A![l2&[i&]+1,1]/A![l2&[i&]+1,kp&+1]
ip& = l2&[i&]
cas (i&+1) > nl2&:RETOUR

WhileLoop i&+1,nl2&:i&=&Boucle

    ii& = l2&[i&]

    IF A![ii&+1,kp&+1] < (-1*EPS!)

        q! = -1*A![ii&+1,1] / A![ii&+1,kp&+1]

        IF q! < q1!

            ip& = ii&
            q1! = q!

        ELSEIF q! = q1! :imprimer " Degenerierter le cas!"

            whileloop n& : k&=1

                qp! = -1*A![ip&+1,k&+1] / A![ip&+1,kp&+1]
                q0! = -1*A![ii&+1,k&+1] / A![ii&+1,kp&+1]
                cas q0! <> qp! : BREAK'GOTO "G2106"

            endwhile

            G2106:
            cas q0! < qp! : ip& = ii&

        ENDIF

    ENDIF

endwhile

RETOUR
S2200:
' Subroutine simp3(a, i1,k1,ip,kp)
piv! = 1 / A![ip&+1,kp&+1]

IF i1&>=0

    whileloop i1&+1:ii&=&Boucle

        IF (ii&-1) <> ip&

            A![ii&,kp&+1] = A![ii&,kp&+1]*piv!

            whileloop k1&+1:kk&=&Boucle

                IF (kk&-1) <> kp&

                    A![ii&,kk&]=A![ii&,kk&]-A![ip&+1,kk&]*A![ii&,kp&+1]

                ENDIF

            endwhile

        ENDIF

    endwhile

ENDIF

whileloop k1&+1:kk&=&Boucle

    cas (kk&-1)<>kp&: A![ip&+1,kk&]= -1*A![ip&+1,kk&]*piv!

endwhile

A![ip&+1,kp&+1] = piv!
RETOUR
' end of file simp.xprf