mirror of
https://github.com/pkimpel/retro-220.git
synced 2026-02-26 08:44:04 +00:00
cf932d5c85
2. Correct and reorder op code table in BAC-Assembler. 3. Commit tools/BAC-DeckGen.cmd script to generate card deck files from transcription files. 4. Add /Q (quiet mode) switch to BAC-Xscript-Reformatter.wsf, correct problem with output of last card. 5. Commit examples 2, 3, and 4 from BALGOL manual; commit corrections to example 1.
212 lines
5.7 KiB
Plaintext
212 lines
5.7 KiB
Plaintext
2 COMMENT FOURTH EXAMPLE PROGRAM FROM BALGOL MANUAL, MARCH 1963.
|
|
2 THE PROGRAM BELOW HAS BEEN WRITTEN BY G. FORSYTHE, OF STANFORD
|
|
2 UNIVERSITY. IT SOLVES A SET OF LINEAR EQUATIONS OF THE FORM AY = B,
|
|
2 USING CROUT'S METHOD WITH INTERCHANGES;
|
|
2
|
|
2 COMMENT FORSYTHE PROGRAM;
|
|
2 PROCEDURE PRODUCT (; N, A(), P, E);
|
|
2 BEGIN COMMENT THIS FORMS THE PRODUCT OF ARBITRARY FLOATING NUMBERS
|
|
2 A(I), FOR I=(1,1,N). EXPONENT OVERFLOW OR UNDERFLOW IS
|
|
2 PREVENTED. THE ANSWER IS P TIMES 10*E WHERE E IS 0 IF POSSIBLE.
|
|
2 IF E NEQ 0, THEN WE NORMALIZE P SO THAT 0.1 LEQ ABS(P) LSS 1.0;
|
|
2 INTEGER E, F, I, K, N;
|
|
2
|
|
2 Q = 1.0**-10; F = 10;
|
|
2 FOR I = (1,1,N);
|
|
2 BEGIN
|
|
2 IF A(I) EQL 0.0;
|
|
2 BEGIN
|
|
2 P = 0.0;
|
|
2 E = 0;
|
|
2 RETURN
|
|
2 END;
|
|
2
|
|
2 IF ABS(A(I)) LEQ 1.0;
|
|
2 BEGIN
|
|
2 F = F-20;
|
|
2 Q = Q.(10.0*20)
|
|
2 END;
|
|
2
|
|
2 Q = Q.A(I);
|
|
2 X = ABS(Q);
|
|
2 FOR K = (-10,1,10), (-11,-1,-41), (11,1,41);
|
|
2 IF ((10.0*K LEQ X) AND (X LSS 10.0*(K+1)));
|
|
2 BEGIN
|
|
2 Q = Q.(10.0*(-10-K));
|
|
2 F = F + 10;
|
|
2 GO TO 1
|
|
2 END;
|
|
2 1.. END;
|
|
2
|
|
2 IF (((-40) LEQ F) AND (F LEQ 58));
|
|
2 BEGIN
|
|
2 P = (Q.(10.0*9).(10.0*(F-9));
|
|
2 E = 0;
|
|
2 RETURN
|
|
2 END;
|
|
2
|
|
2 P = Q.(10.0*9);
|
|
2 E = F - 9;
|
|
2 RETURN
|
|
2 END PRODUCT();
|
|
2
|
|
2 PROCEDURE INNERPRODUCT (S, F, U(), V());
|
|
2 BEGIN COMMENT THIS FORMS THE INNER PRODUCT OF THE VECTORS
|
|
2 U(I) AND V(I) FOR I = (S,1,F);
|
|
2 INTEGER I, S, F;
|
|
2
|
|
2 SUM = 0.0;
|
|
2 FOR I = (S,1,F);
|
|
2 SUM = SUM + U(I).V(I);
|
|
2 INNERPRODUCT() = SUM;
|
|
2 RETURN
|
|
2 END INNERPRODUCT();
|
|
2
|
|
2 PROCEDURE CROUT4 (; N, A(,), B(), Y(), PIVOT(), DET, EX7;
|
|
2 SINGULAR, IP());
|
|
2 BEGIN COMMENT THIS IS CROUTS METHOD WITH INTERCHANGES, TO SOLVE
|
|
2 AY = B AND OBTAIN THE TRIANGULAR DECOMPOSITION. IP() STANDS FOR
|
|
2 AN INNERPRODUCT ROUTINE THAT MUST BE AVAILABLE WHEN CROUT4() IS
|
|
2 CALLED. ALSO, PRODUCT() MUST BE AVAILABLE. THE DETERMINANT OF A
|
|
2 IS COMPUTED IN THE FORM DET TIMES 10*EX7, WHERE EX7 IS 0 IF
|
|
2 POSSIBLE. IF EX7 NEQ 0, THEN WE NORMALIZE DET WITH 0.1 LEQ
|
|
2 ABS(DET) LSS 1;
|
|
2 INTEGER K, I, J, IMAX, N, PIVOT;
|
|
2 INTEGER EX7;
|
|
2
|
|
2 INT = 1.0;
|
|
2 FOR K = (1,1,N);
|
|
2 BEGIN
|
|
2 TEMP = 0;
|
|
2 FOR I = (K,1,N);
|
|
2 BEGIN
|
|
2 A(I,K) = A(I,K) - IP(1, K-1, A(I,), A(,K));
|
|
2 IF ABS(A(I,K)) GTR TEMP;
|
|
2 BEGIN
|
|
2 TEMP = ABS(A(I,K));
|
|
2 IMAX = I
|
|
2 END
|
|
2 END;
|
|
2
|
|
2 PIVOT(K) = IMAX;
|
|
2 COMMENT WE HAVE FOUND THAT A(IMAX,K) IS THE LARGEST PIVOT IN COL
|
|
2 K. NOW WE INTERCHANGE ROWS K AND IMAX;
|
|
2 IF IMAX NEQ K;
|
|
2 BEGIN
|
|
2 INT = -INT;
|
|
2 FOR J = (1,1,N);
|
|
2 BEGIN
|
|
2 TEMP = A(K,J);
|
|
2 A(K,J) = A(IMAX,J);
|
|
2 A(IMAX,J) = TEMP
|
|
2 END;
|
|
2
|
|
2 TEMP = B(K);
|
|
2 B(K) = B(IMAX);
|
|
2 B(IMAX) = TEMP
|
|
2 END;
|
|
2
|
|
2 COMMENT NOW FOR THE ELIMINATION;
|
|
2 IF A(K,K) EQL 0;
|
|
2 BEGIN
|
|
2 DET = 0.0;
|
|
2 EX7 = 0;
|
|
2 GO TO SINGULAR;
|
|
2 END;
|
|
2
|
|
2 FOR I = (K+1,1,N);
|
|
2 BEGIN
|
|
2 XX = A(I,K);
|
|
2 XY = A(K,K);
|
|
2 X = 1.0;
|
|
2 X = X.X;
|
|
2 A(I,K) = XX/XY
|
|
2 END;
|
|
2
|
|
2 FOR J = (K+1,1,N);
|
|
2 A(K,J) = A(K,J) - IP(1, K-1, A(K,), A(,J));
|
|
2
|
|
2 B(K) = B(K) - IP(1, K-1, A(K), B())
|
|
2 END;
|
|
2
|
|
2 FOR I = (1,1,N);
|
|
2 Y(I) = A(I,I);
|
|
2 PRODUCT (; N, Y(), DET, EX7);
|
|
2 DET = INT.DET;
|
|
2
|
|
2 COMMENT NOW FOR THE BACK SUBSTITUTION;
|
|
2 FOR K = (N,-1,1);
|
|
2 BEGIN
|
|
2 XX = B(K) - IP(K+1, N, A(K,), Y());
|
|
2 XY = A(K,K);
|
|
2 X = 1.0;
|
|
2 X = X.X;
|
|
2 Y(K) = XX/XY
|
|
2 END;
|
|
2
|
|
2 RETURN;
|
|
2 END CROUT4();
|
|
2
|
|
2 PROCEDURE SOLV2 (; N, B(,), C(), PIVOT(), Z(), IP());
|
|
2 BEGIN COMMENT IT IS ASSUMED THAT A MATRIX A HAS ALREADY BEEN
|
|
2 TRANSFORMED INTO B BY CROUT, BUT THAT A NEW COLUMN C HAS NOT
|
|
2 BEEN PROCESSED. SOLV2() SOLVES
|
|
2 THE SYSTEM BZ = C. AN INNERPRODUCT PROCEDURE MUST BE USED WITH
|
|
2 SOLV2();
|
|
2 INTEGER K, N, PIVOT;
|
|
2
|
|
2 FOR K = (1,1,N);
|
|
2 BEGIN
|
|
2 TEMP = C(PIVOT(K));
|
|
2 C(PIVOT(K)) = C(K);
|
|
2 C(K) = TEMP;
|
|
2 C(K) = C(K) - IP(1, K-1, B(K,), C())
|
|
2 END;
|
|
2
|
|
2 FOR K = (N,-1,1);
|
|
2 Z(K) = (C(K) - IP(K+1, N, B(K), Z()))/B(K,K); *WAS N,B(K), *
|
|
2 RETURN
|
|
2 END SOLV2();
|
|
2
|
|
2 COMMENT FORSYTHE TEST CROUT US169 EXT 2274;
|
|
2 FORMAT FRMTFL(W0, (6F19.8, W0));
|
|
2 FORMAT FMTFX (W0, (6I19, W0));
|
|
2 INTEGER PIVOT();
|
|
2 INTEGER EX;
|
|
2 INTEGER I, J, N;
|
|
2 ARRAY A(70,70, B(70), Y(70), C(70), PIVOT(70); *WAS A(70,70, B(*
|
|
2 INPUT DATA (N, FOR I=(1,1,N); (FOR J=(1,1,N); A(I,J), B(I)));
|
|
2 INPUT VECTOR (N, FOR I=(1,1,N); C(I));
|
|
2
|
|
2 START..
|
|
2 READ (;; DATA);
|
|
2 READ (;; VECTOR);
|
|
2 OUTPUT ORDER (N);
|
|
2 OUTPUT DATAO (FOR I=(1,1,N); (FOR J=(1,1,N); A(I,J), B(I)));
|
|
2 OUTPUT VECTORO (FOR I=(1,1,N); C(I));
|
|
2 WRITE (;; ORDER, FRMTFX);
|
|
2 WRITE (;; DATAO, FRMTFL);
|
|
2 WRITE (;; ORDER, FRMTFX);
|
|
2 WRITE (;; VECTORO, FRMTFL);
|
|
2 CROUT4 (; N, A(,), B(), Y(), PIVOT(), DET, EX;
|
|
2 SINGULAR, INNERPRODUCT());
|
|
2 WRITE (;; DATAO, FRMTFL);
|
|
2 OUTPUT ANSWER (FOR I=(1,1,N); Y(I));
|
|
2 OUTPUT PIVOTO (N, FOR I=(1,1,N); PIVOT(I));
|
|
2 OUTPUT DETO (DET);
|
|
2 OUTPUT EXPO (EX);
|
|
2 WRITE (;; PIVOTO, FRMTFX);
|
|
2 WRITE (;; ANSWER, FRMTFL);
|
|
2 WRITE (;; DETO, FRMTFL);
|
|
2 WRITE (;; EXPO, FRMTFX);
|
|
2 SOLV2 (; N, A(,), C(), PIVOT(), Y(); INNERPRODUCT());
|
|
2 WRITE (;; VECTORO, FRMTFL);
|
|
2 WRITE (;; ANSWER, FRMTFL);
|
|
2 GO TO START;
|
|
2
|
|
2 SINGULAR..
|
|
2 WRITE (;; FRMTSI);
|
|
2 FORMAT FRMTSI (W0, *SINGULAR*, W0);
|
|
2 GO TO START;
|
|
2 FINISH;
|