github.com/pkimpel.retro-b5500
1
0
Fork 0
mirror of https://github.com/pkimpel/retro-b5500.git synced 2026-02-18 21:57:21 +00:00
Code Releases Activity
Files
127edd65d528a268f00a5f89ced7986ffc90faab
pkimpel.retro-b5500/tests/E-mode/ORTHO-XEM.alg_m

258 lines
23 KiB
Plaintext
Raw Blame History

% -ORTHO- TEST, 3/3/70 00000100120429PK
BEGIN 00000200
INTEGER STARTT; 00000300120429PK
FORMAT FT (//"DATE: "A6" PROC TIME: "F8.2" I/O TIME: "F8.2" ELAPSED: " 00000400120429PK
F8.2" SEC"); 00000500120429PK
INTEGER I, J, N, M, P, R, AI, AUI, ZEI, MUI; 00000600120429PK
REAL SUM, GMDT, FN; 00000700120429PK
FILE PARAMS (KIND=READER, DEPENDENTSPECS); 00000800120826PK
FILE FLUSH (KIND=PRINTER, MAXRECSIZE=132, FRAMESIZE=8, FILEUSE=OUT); 00000900120826PK
00001000120429PK
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%00002000120429PK
PROCEDURE ORTHO (W, Y, Z, N, FN, M, P, R, AI, AUI, MUI, ZEI, X, DEV, 00003000
COF, STD, CV, VCV, GMDT, Q, Q2, E, EP, A, GF, ENF); 00004000
VALUE N, M, P, R, AI, AUI, MUI, ZEI; 00005000
REAL FN, GMDT; 00006000
REAL ARRAY STD, GF, W, ENF [1]; 00007000
REAL ARRAY Y, Z, X, DEV, COF, CV, Q, Q2, E, EP, A [1, 1]; 00008000
REAL ARRAY VCV [1, 1, 1]; 00009000
INTEGER N, M, P, R, AI, AUI, ZEI, MUI; 00010000
00011000120429PK
COMMENT 00012000
ORTHO IS TAKEN FROM ACM ALGORITHM 127 [COMM. ACM, VOL.5, 00013000
OCTOBER 1962, P. 511, AUTHOR: PHILIP J. WALSH]; 00014000
00015000120429PK
BEGIN 00016000
INTEGER NPP, NPM, M1, N2, M2, R1, RBAR, P2, BEI, RHI, I18, GAI, SII, I,00017000
J, DEI, NUI, E1Z2, E1Z1, K, THI, ALI, OMI, NII; 00018000
REAL ARRAY PK, XP [1:N+P], QK[1:M+1]; 00019000
REAL DENOM, SUM, DK2, DK, FI, SS, SSQ; 00020000
LABEL BOX1, AT1, AT2, BOX2, AU1, AU2, BOX3, BOX4, BOX5, BOX6, MU1, 00021000
MU2, BOX7, OM1, OM2, BOX8, DE1, BOX8A, BOX8B, DE2, BOX8C, BOX8D, 00022000
BOX9, TH1, TH2, TH3, BOX10, AL1, AL2, BOX11, NU1, NU2, BOX12, 00023000
BE1, BE2, BOX13, GA1, GA2, BOX14, RH1, ZE1, ZE2, RH2, SI1, SI2, 00024000
FINAL; 00025000
SWITCH AT:= AT1, AT2; SWITCH ZE:= ZE1, ZE2; 00026000120826PK
SWITCH AU:= AU1, AU2; SWITCH MU:= MU1, MU2; 00027000120826PK
SWITCH BE:= BE1, BE2; SWITCH RH:= RH1, RH2; SWITCH GA:= GA1, GA2; 00028000120826PK
SWITCH SI:= SI1, SI2; SWITCH DE:= DE1, DE2; SWITCH NU:= NU1, NU2; 00029000120826PK
SWITCH TH:= TH1, TH2, TH3; SWITCH AL:= AL1, AL2; 00030000120826PK
SWITCH OM:= OM1, OM2; 00031000120826PK
NPP:= N+P; NPM:= N+M; M1:= M-1; N2:= N+1; M2:= M+1; 00032000120826PK
R1:= 0; RBAR:= R; P2:= P+1; DENOM:= IF N=M THEN 1.0 00033000120826PK
ELSE SQRT(N-M); BEI:= RHI:= I18:= 1; 00034000120826PK
IF (P ^= 0) THEN GAI:= SII:= 2 ELSE GAI:= SII:= 1; 00035000120826PK
BOX1: GO TO AT[AI]; 00036000
AT1: FOR J:= 1 STEP 1 UNTIL N DO BEGIN 00037000120826PK
X[2,J]:= Z[1,J]; X[1,J]:= 1.0 END; 00038000120826PK
FOR I:= 2 STEP 1 UNTIL M1 DO BEGIN 00039000120826PK
FOR J:= 1 STEP 1 UNTIL N DO 00040000120826PK
X[I+1,J]:= X[I,J] * X[2,J] END; GO TO BOX2; 00041000120826PK
AT2: FOR I:= 1 STEP 1 UNTIL M DO BEGIN 00042000120826PK
FOR J:= 1 STEP 1 UNTIL N DO 00043000120826PK
X[I,J]:= Z[I,J] END; 00044000120826PK
BOX2: IF P = 0 THEN GO TO BOX3 ELSE GO TO AU[AUI]; 00045000
AU1: FOR I:= 1 STEP 1 UNTIL M DO BEGIN 00046000120826PK
FOR J:= N2 STEP 1 UNTIL NPP DO 00047000120826PK
X[I,J]:= 0.0; X[I,N+I]:= 1.0 END; GO TO BOX3; 00048000120826PK
AU2: FOR I:= 1 STEP 1 UNTIL M DO BEGIN 00049000120826PK
FOR J:= N2 STEP 1 UNTIL NPP DO 00050000120826PK
X[I,J]:= Z[I,J] END; 00051000120826PK
BOX3: DEI:= NUI:= E1Z1:= E1Z2:= K:= 1; 00052000120826PK
BOX4: THI:= 1; 00053000120826PK
BOX5: ALI:= OMI:= 1; IF P = 0 THEN GO TO BOX6 ELSE 00054000120826PK
FOR J:= 1 STEP 1 UNTIL P DO PK[N+J]:= 0.0; 00055000120826PK
BOX6: GO TO MU[MUI]; 00056000
MU1: FOR I:= 1 STEP 1 UNTIL N DO PK[I]:= X[K,I]; 00057000120826PK
GO TO BOX7; 00058000
MU2: FOR I:= 1 STEP 1 UNTIL N DO 00059000120826PK
PK[I]:= X[K,I] * W[I]; GO TO BOX7; 00060000120826PK
BOX7: GO TO OM[OMI]; 00061000
OM1: FOR I:= 1 STEP 1 UNTIL K DO BEGIN SUM:= 0.0; 00062000120826PK
FOR J:= 1 STEP 1 UNTIL NPP DO 00063000120826PK
SUM:= SUM + PK[J] * X[I,J]; QK[I]:= SUM END; 00064000120826PK
GO TO BOX8; 00065000
OM2: DK2:= 0.0; FOR I:= 1 STEP 1 UNTIL NPP DO 00066000120826PK
DK2:= DK2 + PK[I] * X[K,I]; 00067000120826PK
DK:= SQRT(DK2); 00068000120826PK
GF[I18]:= DK; I18:= I18 + 1; 00069000120826PK
FOR I:= 1 STEP 1 UNTIL NPP DO 00070000120826PK
X[K,I]:= X[K,I]/DK;; 00071000120826PK
OMI:= 1; GO TO BOX6; 00072000120826PK
BOX8: GO TO DE[DEI]; 00073000
DE1: E1Z1:= -E1Z1; IF E1Z1 < 0 THEN GO TO BOX8B ELSE 00074000120826PK
GO TO BOX8A; 00075000
BOX8A: FOR I:= 1 STEP 1 UNTIL K-1 DO 00076000120826PK
QK[I]:= -QK[I]; QK[K]:= 1.0; 00077000120826PK
FOR I:= 1 STEP 1 UNTIL NPP DO BEGIN 00078000120826PK
SUM:= 0.0; FOR J:= 1 STEP 1 UNTIL K DO 00079000120826PK
SUM:= SUM + X[J,I] * QK[J]; 00080000120826PK
XP[I]:= SUM END; GO TO BOX9; 00081000120826PK
BOX8B: ENF[I18]:= SQRT(QK[K]); GO TO BOX8A; 00082000120826PK
DE2: E1Z2:= -E1Z2; IF E1Z2 < 0 THEN GO TO BOX8C ELSE 00083000120826PK
GO TO BOX8A; 00084000
BOX8C: FOR I:= 1 STEP 1 UNTIL M DO BEGIN 00085000120826PK
Q[R1,I]:= QK[I]; Q2[R1,I]:= QK[I] * QK[I] END; 00086000120826PK
Q[R1,M2]:= QK[M2]; E[R1,1]:= Q[R1,M2] - Q2[R1,1]; 00087000120826PK
FOR J:= 2 STEP 1 UNTIL M DO 00088000120826PK
E[R1,J]:= E[R1,J-1] - Q2[R1,J]; 00089000120826PK
FI:= 1.0; 00090000120826PK
FOR I:= 1 STEP 1 UNTIL M DO BEGIN 00091000120826PK
IF (FN - FI) > 0.0 THEN BEGIN IF E[R1,I] < 0.0 THEN 00093000
BEGIN EP[R1,I]:= -SQRT(ABS(E[R1,I])/(FN - FI)); 00094000120826PK
GO TO BOX8D; END 00095000
ELSE EP[R1,I]:= SQRT(E[R1,I]/(FN - FI)); 00096000120826PK
GO TO BOX8D; END ELSE E[R1,I]:= -1.0; 00097000120826PK
BOX8D: FI:= FI + 1.0; END; GO TO BOX8A; 00098000120826PK
BOX9: GO TO TH[THI]; 00099000
TH1: FOR I:= 1 STEP 1 UNTIL NPP DO 00100000120826PK
X[K,I]:= XP[I]; GO TO BOX10; 00101000120826PK
TH2: FOR I:= 1 STEP 1 UNTIL N DO 00102000120826PK
DEV[R1,I]:= XP[I]; 00103000120826PK
FOR I:= 1 STEP 1 UNTIL P DO 00104000120826PK
COF[R1,I]:= -XP[N+I]; THI:= 3; GO TO TH1; 00105000120826PK
TH3: GO TO BOX11; 00106000
BOX10: GO TO AL[ALI]; 00107000
AL1: OMI:= ALI:= 2; GO TO BOX6; 00108000120826PK
AL2: IF K < M THEN BEGIN K:= K + 1; GO TO BOX4; END 00109000120826PK
ELSE GO TO BOX12; 00110000
BOX11: GO TO NU[NUI]; 00111000
NU1: NUI:= 2; GO TO BOX14; 00112000120826PK
NU2: SS:= DK/DENOM; SSQ:= SS * SS; 00113000120826PK
STD[R1]:= SS; GO TO BOX14; 00114000120826PK
BOX12: GO TO BE[BEI]; 00115000
BE1: FOR I:= 1 STEP 1 UNTIL M DO BEGIN 00116000120826PK
FOR J:= 1 STEP 1 UNTIL P DO 00117000120826PK
A[I,J]:= X[I,N+J] END; 00118000120826PK
GMDT:= 1.0; FOR I:= 1 STEP 1 UNTIL M DO 00119000120826PK
GMDT:= GMDT * (GF[I]/ENF[I]); 00120000120826PK
GMDT:= GMDT * GMDT; DEI:= BEI:= THI:= 2; 00121000120826PK
K:= K + 1; GO TO BOX13; 00122000120826PK
BE2: GO TO BOX11; 00123000
BOX13: GO TO GA[GAI]; 00124000
GA1: GO TO BOX11; 00125000
GA2: FOR I:= 1 STEP 1 UNTIL P DO BEGIN 00126000120826PK
FOR J:= I STEP 1 UNTIL P DO BEGIN 00127000120826PK
SUM:= 0.0; 00128000120826PK
FOR NII:= 1 STEP 1 UNTIL M DO 00129000120826PK
SUM:= SUM + A[NII,I] * A[NII,J]; 00130000120826PK
CV[I,J]:= SUM END END; 00131000120826PK
FOR I:= 1 STEP 1 UNTIL P DO 00132000120826PK
CV[P2,I]:= SQRT(CV[I,I]); GAI:= 1; GO TO BOX11; 00133000120826PK
BOX14: GO TO RH[RHI]; 00134000
RH1: IF RBAR = 0 THEN GO TO FINAL ELSE RBAR:= RBAR - 1; 00135000120826PK
R1:= R1 + 1; THI:= RHI:= 2; GO TO ZE[ZEI]; 00136000120826PK
ZE1: FOR I:= 1 STEP 1 UNTIL N DO 00137000120826PK
X[M2,I]:= Y[R1,I]; 00138000120826PK
FOR I:= 1 STEP 1 UNTIL P DO 00139000120826PK
X[M2,N+I]:= 0.0; GO TO BOX5; 00140000120826PK
ZE2: FOR I:= 1 STEP 1 UNTIL NPP DO 00141000120826PK
X[M2,I]:= Y[R1,I]; GO TO BOX5; 00142000120826PK
RH2: GO TO SI[SII]; 00143000
SI1: GO TO RH1; 00144000
SI2: FOR I:= 1 STEP 1 UNTIL P DO BEGIN 00145000120826PK
FOR J:= I STEP 1 UNTIL P DO 00146000120826PK
VCV[R1,I,J]:= SSQ * CV[I,J] END; 00147000120826PK
FOR I:= 1 STEP 1 UNTIL P DO 00148000120826PK
VCV[R1, P2, I]:= SS * CV[P2,I]; GO TO RH1; 00149000120826PK
FINAL: END ORTHO ; 00150000
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%00151000120429PK
00152000120429PK
PROCEDURE DUMP1 (CAPTION, A); 00800000120826PK
VALUE CAPTION; 00800100120826PK
ALPHA CAPTION; 00800200120826PK
ARRAY A[0]; 00800300120826PK
BEGIN 00800400120826PK
INTEGER 00800500120826PK
UB1, 00800600120826PK
X; 00800700120826PK
00800800120826PK
UB1:= SIZE(A)-1; 00800900120826PK
WRITE (FLUSH, <A6," = ">, CAPTION); 00801000120826PK
WRITE (FLUSH, <6E19.11>, 00801100120826PK
FOR X:= 0 STEP 1 UNTIL UB1 DO A[X]); 00801200120826PK
WRITE (FLUSH); 00801300120826PK
END DUMP1; 00801400120826PK
00810000120826PK
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%00810100120826PK
PROCEDURE DUMP2 (CAPTION, A); 00810200120826PK
VALUE CAPTION; 00810300120826PK
ALPHA CAPTION; 00810400120826PK
ARRAY A[0,0]; 00810500120826PK
BEGIN 00810600120826PK
INTEGER 00810700120826PK
UB1, 00810800120826PK
UB2, 00810900120826PK
X, 00811000120826PK
Y; 00811100120826PK
00811200120826PK
UB1:= SIZE(A)-1; 00811300120826PK
WRITE (FLUSH, <A6," = ">, CAPTION); 00811400120826PK
FOR X:= 0 STEP 1 UNTIL UB1 DO 00811500120826PK
BEGIN 00811600120826PK
UB2:= SIZE(A[X,*])-1; 00811700120826PK
WRITE (FLUSH, <6E19.11>, 00811800120826PK
FOR Y:= 0 STEP 1 UNTIL UB2 DO A[X,Y]); 00811900120826PK
END FOR X; 00812000120826PK
WRITE (FLUSH); 00812100120826PK
END DUMP2; 00812200120826PK
00900000120826PK
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%00900100120826PK
STARTT:= TIME(1); 00901000120826PK
%%READ (PARAMS, /, N, M, P); 00902000120826PK
%%CLOSE(PARAMS); 00903000120826PK
N:= 7; M:= 5; P:= 5; % PARAMETER VALUES ORIGINALLY READ IN 00903100120826PK
R:= 1; AI:= 2; AUI:= 1; 00904000120826PK
ZEI:= 1; MUI:= 2; FN:= N; 00905000120826PK
00906000120429PK
BEGIN %INNER BLOCK 00907000120429PK
LABEL DUMPIT; 00908000120429PK
REAL ARRAY W[1:N], Y[1:R, 1:N+P], Z[1:M, 1:N+P], 00909000120429PK
X[1:M+1, 1:N+P], DEV[1:R, 1:N], COF[1:R, 1:P], STD[1:R], 00910000120429PK
CV[1:P+1, 1:P], VCV[1:R, 1:P+1, 1:P], Q[1:R, 1:M+1], 00911000120429PK
Q2, E, EP [1:R, 1:M], A[1:M, 1:P], GF[1:M+R], ENF[1:M]; 00912000120429PK
%%DUMP FLUSH (N, M, P, R, AI, AUI, ZEI, MUI, 00913000120826PK
%% GMDT, FN, 00914000120826PK
%% W, Y, Z, X, DEV, COF, STD, CV, VCV, Q, Q2, A, GF, ENF, E, 00915000120826PK
%% EP) DUMPIT:1; 00916000120826PK
FOR I:= 1 STEP 1 UNTIL N DO 00917000120826PK
BEGIN 00918000120429PK
W[I]:= 1.0; SUM:= 0.0; 00919000120826PK
FOR J:= 1 STEP 1 UNTIL M DO 00920000120826PK
SUM:= SUM + J*(Z[J,I]:= I*J); 00921000120826PK
Y[1,I]:= SUM; 00922000120826PK
END; 00922500120430PK
ORTHO (W, Y, Z, N, FN, M, P, R, AI, AUI, MUI, ZEI, X, DEV, 00923000120429PK
COF, STD, CV, VCV, GMDT, Q, Q2, E, EP, A, GF, ENF); 00924000120429PK
00924500120430PK
WRITE(FLUSH, <"N = ",I13,/, 00924510120826PK
"M = ",I13,/, 00924520120826PK
"P = ",I13,/, 00924530120826PK
"R = ",I13,/, 00924540120826PK
"AI = ",I13,/, 00924550120826PK
"AUI = ",I13,/, 00924560120826PK
"ZEI = ",I13,/, 00924570120826PK
"MUI = ",I13,/, 00924580120826PK
"GMDT = ",E19.11,/, 00924590120826PK
"FN = ",E19.11,/>, 00924600120826PK
N, M, P, R, AI, AUI, ZEI, MUI, GMDT, FN); 00924610120826PK
DUMP1("W ", W); 00924620120826PK
DUMP2("Y ", Y); 00924630120826PK
DUMP2("Z ", Z); 00924640120826PK
DUMP2("X ", X); 00924650120826PK
DUMP2("DEV ", DEV); 00924660120826PK
DUMP2("COF ", COF); 00924670120826PK
DUMP1("STD ", STD); 00924680120826PK
DUMP2("CV ", CV); 00924690120826PK
DUMP2("VCV ", VCV[1,*,*]); 00924700120826PK
DUMP2("Q ", Q); 00924710120826PK
DUMP2("Q2 ", Q2); 00924720120826PK
DUMP2("A ", A); 00924730120826PK
DUMP1("GF ", GF); 00924740120826PK
DUMP1("ENF ", ENF); 00924750120826PK
DUMP2("E ", E); 00924760120826PK
DUMP2("EP ", EP); 00924770120826PK
DUMPIT: END INNER BLOCK; 00925000120429PK
WRITE(FLUSH, FT, TIME(0), TIME(2)/60, TIME(3)/60, (TIME(1)-STARTT)/60); 00926000120429PK
END. 00999000
View Git Blame Copy Permalink