XProfan

Windowtitle "LU-Faktorisierung avec Zeilentausch, pour mehrfache LGS-Lösung"
Font 2:randomize:CLS rnd(8^8)
AppendMenuBar 10,"Obere Dreiecksmatrix via Grundstruktur, anschl. sommes mehrfach Lösungen par Vektor-Rücktausch möglich"
'{ (D) Demoware 2012-06-01 P. Specht, vienne per Übersetzung aus HP-Basic.
' sans jedwede Gewähr! Nutzung sur eigenes Risiko des Anwenders!
' qui Originalvorlage hatte folgende Rechtshinweise:
'  Copyright  1987
'   John H. Mathews
'   Dept. of Mathematics
'   California State University, Fullerton
'   LU Factorization with Row Interchanges
'}  PROGRAM LU FACTOR AND SOLVE
'{          ' MAIN PART
Déclarer A![10,10], A1![10,10], B![10], ROW&[10], X![10]
Déclarer n&,i&,j&,k&,inrc!,à l'$,row&,col&,ah$,tmp$,det!
Déclarer p&,rowk&,rowp&,c&,t&,sum!
g110:
p300' call SUBROUTINE INPUTS
p1000' call SUBROUTINE FACTOR
g125:
Imprimer "\nENTER THE COLUMN VECTOR  B:"
p900' call SUBROUTINE VECTOR INPUT
cas DET!<>0:p1500' call SUBROUTINE SOLVE
p3000' call SUBROUTINE RESULTS

Si DET!<>0

    Imprimer " WANT TO SOLVE A*X=B WITH A NEW VECTOR B ? <Y/N> ";
    Contribution ANS$
    Cas (ANS$="Y") Or (ANS$="y")  Or (ANS$="j") Or (ANS$="J") : Goto "g125"

EndIf

Imprimer " WANT TO SOLVE ANOTHER LINEAR SYSTEM ? <Y/N> ";
Contribution ANS$:Cas (ANS$="Y") Or (ANS$="y")  Or (ANS$="J") Or (ANS$="j"):Goto "g110"
Fin
'}

Proc p300' INPUT CONTROL

    CLS rnd(8^8)
    Imprimer "\n SOLUTION OF A LINEAR SYSTEM  A[ , ] * X[ ] = B[ ] "
    Imprimer
    Imprimer " THE TRIANGULAR FACTORIZATION L * U = P * A  IS CONSTRUCTED."
    Imprimer " FIRST,  THE SOLUTION  Y  TO  L * Y = P * B  IS FOUND,"
    Imprimer " SECOND, THE SOLUTION  X  TO  U * X = Y    IS FOUND."
    Imprimer
    Imprimer " A[ , ] IS AN  N BY N  NONSINGULAR MATRIX."
    Imprimer " B[ ]   IS AN  N DIMENSIONAL VECTOR OF CONSTANTS."
    Imprimer " X[ ]   IS THE N DIMENSIONAL SOLUTION VECTOR OF A*X=B"
    Imprimer
    Imprimer " ENTER NUMBER OF EQUATIONS: N = ";
    Contribution N&
    INRC!=0
    Imprimer " DO YOU WANT TO INPUT PER COLUMN? (Y=COLUMNS, N=ROWS) <Y/N> ";
    Contribution ANS$
    Cas (ANS$="Y") Or (ANS$="y") Or (ANS$="J") Or (ANS$="j") : INRC!=1
    Imprimer
    Imprimer " ENTER THE MATRIX A(I,J) TO BE TRIANGLED:"
    p600'  call SUBROUTINE MATRIX INPUT
    Retour

ENDPROC

Proc p600' SUBROUTINE MATRIX INPUT

    WhileLoop n&:row&=&Boucle

        WhileLoop n&:col&=&Boucle

            A![ROW&,COL&]=0

        Endwhile

    Endwhile

    'Imprimer " ELEMENTS OF THE MATRIX "

    Si INRC!=0

        Goto "g690"

    D'autre

        Goto "g780"

    EndIf

    g690:

    WhileLoop n&:row&=&Boucle

        Imprimer "\n INPUT THE ELEMENTS OF ROW ",ROW&
        Imprimer

        WhileLoop n&:col&=&Boucle

            Imprimer "A(";ROW&;»;COL&;") = ";
            Contribution A![ROW&,COL&]
            A1![ROW&,COL&] = A![ROW&,COL&]

        Endwhile

    Endwhile

    Goto "g870"
    g780:

    WhileLoop n&:col&=&Boucle

        Imprimer "\n INPUT THE ELEMENTS OF COLUMN ",COL&
        Imprimer

        WhileLoop n&:row&=&Boucle

            Imprimer " A(";ROW&;»;COL&;") = ";
            Contribution tmp$
            A![ROW&,COL&]=val(tmp$)
            A1![ROW&,COL&] = A![ROW&,COL&]

        Endwhile

    Endwhile

    g870:

ENDPROC

Proc p900' SUBROUTINE VECTOR INPUT

    Imprimer

    WhileLoop n&:row&=&Boucle

        Imprimer " B(";ROW&;") = ";:Contribution tmp$:B![ROW&]=Val(tmp$)

    Endwhile

ENDPROC

Proc p1000' SUBROUTINE FACTOR

    declare skip&
    DET!=1

    Whileloop n&:j&=&Boucle

        ROW&[J&]=J&

    Endwhile

    WHILELOOP n&-1:p&=&Boucle

        WhileLoop p&+1,n&:k&=&Boucle

            Si  Abs(A![ROW&[K&],P&]) > Abs(A![ROW&[P&],P&])

                Goto "g1080"

            D'autre

                Goto "g1120"

            EndIf

            g1080:
            T&=ROW&[P&]
            ROW&[P&]=ROW&[K&]
            ROW&[K&]=T&
            DET!= -1*DET!
            g1120:

        Endwhile

        DET!=DET!*A![ROW&[P&],P&]
        Cas  DET!=0:skip&=1:BREAK'Goto "g1260"

        WhileLoop p&+1,n&:k&=&Boucle

            ROWK&=ROW&[K&]
            ROWP&=ROW&[P&]
            A![ROWK&,P&] = A![ROWK&,P&] / A![ROWP&,P&]

            Tandis que p&+1,n&:c&=&Boucle

                A![ROWK&,C&] = A![ROWK&,C&] - A![ROWK&,P&] * A![ROWP&,C&]

            Endwhile

        Endwhile

    ENDWHILE

    casenot skip&:DET!=DET!*A![ROW&[N&],N&]
    g1260:

ENDPROC

Proc p1500' SUBROUTINE SOLVE

    Whileloop n&:k&=&Boucle

        Cas A![ROW&[K&],K&]=0:Goto "g1720"

    Endwhile

    X![1]=B![ROW&[1]]

    WhileLoop 2,N&:K&=&Boucle

        SUM!=0
        ROWK&=ROW&[K&]

        WhileLoop k&-1:c&=&Boucle

            SUM!=SUM!+A![ROWK&,C&]*X![C&]

        Endwhile

        X![K&]=B![ROWK&]-SUM!

    Endwhile

    X![N&]=X![N&] / A![ROW&[N&],N&]

    WhileLoop n&-1,1,-1:k&=&Boucle

        SUM!=0
        ROWK&=ROW&[K&]

        WhileLoop k&+1,n&,1:C&=&Boucle

            SUM!=SUM!+A![ROWK&,C&]*X![C&]

        Endwhile

        X![K&]=(X![K&]-SUM!)/A![ROWK&,K&]

    Endwhile

    g1720:

ENDPROC

Proc p2000' SUBROUTINE MATRIX PRINT

    WhileLoop n&:row&=&Boucle

        Imprimer

        WhileLoop n&:col&=&Boucle

            Imprimer A1![ROW&,COL&],

        Endwhile

    Endwhile

ENDPROC

Proc p2100' SUBROUTINE VECTOR PRINT

    COL&=N&+1
    Imprimer " B COEFFICIENT VECTOR                ";"X SOLUTION VECTOR"
    Imprimer

    WhileLoop n&:Row&=&Boucle

        Imprimer " B(";ROW&;") = ";B![ROW&];"    ";"X(";ROW&;") = ",X![ROW&]

    Endwhile

ENDPROC

Proc p3000' SUBROUTINE RESULTS

    CLS rnd(8^8)
    Imprimer "\n COMPUTATION OF THE SOLUTION FOR THE LINEAR SYSTEM A*X = B."
    Imprimer " THE TRIANGULAR FACTORIZATION L*U = P*A WAS CONSTRUCTED"
    Imprimer " FIRST,  THE SOLUTION  Y  TO  L*Y = P*B WAS FOUND,"
    Imprimer " SECOND, THE SOLUTION  X  TO  U*X = Y   WAS FOUND."
    Imprimer " THE COEFFICIENT MATRIX  A  IS:"
    Imprimer
    p2000' call  SUBROUTINE MATRIX PRINT

    Si  DET! = 0

        Goto "g3140"

    D'autre

        Goto "g3220"

    EndIf

    g3140:
    Imprimer " THE MATRIX IS SINGULAR."
    Imprimer " A ZERO PIVOT ELEMENT WAS ENCOUNTERED."
    Imprimer " THE MATRIX DOES NOT HAVE TRIANGULAR FACTORIZATION."
    Imprimer " THE METHOD DOES NOT APPLY."
    Goto "g3250"
    g3220:
    Imprimer
    p2100' call  SUBROUTINE VECTOR PRINT
    g3250:
    Imprimer
    Imprimer " THE DETERMINANT'S VALUE IS  DET A = ",DET!

ENDPROC