XProfan

Windowtitle "LU-Faktorisierung mit Zeilentausch, per mehrfache LGS-Lösung"
Font 2:randomize:CLS rnd(8^8)
AppendMenuBar 10,"Obere Dreiecksmatrix via Grundstruktur, anschl. sind mehrfach Lösungen durch Vektor-Rücktausch möglich"
'{ (D) Demoware 2012-06-01 P. Specht, Wien per Übersetzung aus HP-Basic.
' Ohne jedwede Gewähr! Nutzung auf eigenes Risiko des Anwenders!
' Die 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
Declare A![10,10], A1![10,10], B![10], ROW&[10], X![10]
Declare n&,i&,j&,k&,inrc!,ans$,row&,col&,ach$,tmp$,det!
Declare p&,rowk&,rowp&,c&,t&,sum!
g110:
p300' call SUBROUTINE INPUTS
p1000' call SUBROUTINE FACTOR
g125:
Print "\nENTER THE COLUMN VECTOR  B:"
p900' call SUBROUTINE VECTOR INPUT
case DET!<>0:p1500' call SUBROUTINE SOLVE
p3000' call SUBROUTINE RESULTS

If DET!<>0

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

EndIf

Print " WANT TO SOLVE ANOTHER LINEAR SYSTEM ? <Y/N> ";
Input ANS$:Case (ANS$="Y") Or (ANS$="y")  Or (ANS$="J") Or (ANS$="j"):Goto "g110"
End
'}

Proc p300' INPUT CONTROL

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

EndProc

Proc p600' SUBROUTINE MATRIX INPUT

    WhileLoop n&:row&=&Loop

        WhileLoop n&:col&=&Loop

            A![ROW&,COL&]=0

        EndWhile

    EndWhile

    'Print " ELEMENTS OF THE MATRIX "

    If INRC!=0

        Goto "g690"

    Else

        Goto "g780"

    EndIf

    g690:

    WhileLoop n&:row&=&Loop

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

        WhileLoop n&:col&=&Loop

            Print "A(";ROW&;",";COL&;") = ";
            Input A![ROW&,COL&]
            A1![ROW&,COL&] = A![ROW&,COL&]

        EndWhile

    EndWhile

    Goto "g870"
    g780:

    WhileLoop n&:col&=&Loop

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

        WhileLoop n&:row&=&Loop

            Print " A(";ROW&;",";COL&;") = ";
            Input tmp$
            A![ROW&,COL&]=val(tmp$)
            A1![ROW&,COL&] = A![ROW&,COL&]

        EndWhile

    EndWhile

    g870:

EndProc

Proc p900' SUBROUTINE VECTOR INPUT

    Print

    WhileLoop n&:row&=&Loop

        Print " B(";ROW&;") = ";:Input tmp$:B![ROW&]=Val(tmp$)

    EndWhile

EndProc

Proc p1000' SUBROUTINE FACTOR

    declare skip&
    DET!=1

    Whileloop n&:j&=&Loop

        ROW&[J&]=J&

    EndWhile

    WHILELOOP n&-1:p&=&Loop

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

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

                Goto "g1080"

            Else

                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&]
        Case  DET!=0:skip&=1:BREAK'Goto "g1260"

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

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

            While p&+1,n&:c&=&Loop

                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&=&Loop

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

    EndWhile

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

    WhileLoop 2,N&:K&=&Loop

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

        WhileLoop k&-1:c&=&Loop

            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&=&Loop

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

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

            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&=&Loop

        Print

        WhileLoop n&:col&=&Loop

            Print A1![ROW&,COL&],

        EndWhile

    EndWhile

EndProc

Proc p2100' SUBROUTINE VECTOR PRINT

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

    WhileLoop n&:Row&=&Loop

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

    EndWhile

EndProc

Proc p3000' SUBROUTINE RESULTS

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

    If  DET! = 0

        Goto "g3140"

    Else

        Goto "g3220"

    EndIf

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

EndProc