comment ================== 34010 ================= ;
real procedure VECVEC(L, U, SHIFT, A, B); value L, U, SHIFT;
integer L, U, SHIFT; array A, B;
begin integer K; real S;
S := 0;
for K := L step 1 until U do S := A[K] × B[SHIFT + K] + S;
VECVEC := S
end VECVEC;
comment ================== 34011 ================= ;
real procedure MATVEC(L, U, I, A, B); value L, U, I;
integer L, U, I; array A, B;
begin integer K; real S;
S := 0;
for K := L step 1 until U do S := A[I, K] × B[K] + S;
MATVEC := S
end MATVEC;
comment ================== 34012 ================= ;
real procedure TAMVEC(L, U, I, A, B); value L, U, I;
integer L, U, I; array A, B;
begin integer K; real S;
S := 0;
for K := L step 1 until U do S := A[K, I] × B[K] + S;
TAMVEC := S
end TAMVEC;
comment ================== 34013 ================= ;
real procedure MATMAT(L, U, I, J, A, B); value L, U, I, J;
integer L, U, I, J; array A, B;
begin integer K; real S;
S := 0;
for K := L step 1 until U do S := A[I, K] × B[K, J] + S;
MATMAT := S
end MATMAT;
comment ================== 34014 ================= ;
real procedure TAMMAT(L, U, I, J, A, B); value L, U, I, J;
integer L, U, I, J; array A, B;
begin integer K; real S;
S := 0;
for K := L step 1 until U do S := A[K, I] × B[K, J] + S;
TAMMAT := S
end TAMMAT;
comment ================== 34015 ================= ;
real procedure MATTAM(L, U, I, J, A, B); value L, U, I, J;
integer L, U, I, J; array A, B;
begin integer K; real S;
S := 0;
for K := L step 1 until U do S := A[I, K] × B[J, K] + S;
MATTAM := S
end MATTAM;
comment ================== 34016 ================= ;
real procedure SEQVEC(L, U, IL, SHIFT, A, B);
value L, U, IL, SHIFT; integer L, U, IL, SHIFT; array A, B;
begin real S;
S := 0;
for L := L step 1 until U do
begin S := A[IL] × B[L + SHIFT] + S; IL := IL + L end;
SEQVEC := S
end SEQVEC;
comment ================== 34017 ================= ;
real procedure SCAPRD1(LA, SA, LB, SB, N, A, B);
value LA, SA, LB, SB, N; integer LA, SA, LB, SB, N; array A, B;
begin real S; integer K;
S := 0;
for K := 1 step 1 until N do
begin S := A[LA] × B[LB] + S; LA := LA + SA; LB := LB + SB end;
SCAPRD1 := S
end SCAPRD1;
comment ================== 34018 ================= ;
real procedure SYMMATVEC(L, U, I, A, B); value L, U, I;
integer L, U, I; array A, B;
begin integer K, M;
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
real procedure SEQVEC(L, U, IL, SHIFT, A, B); code 34016;
M := if L > I then L else I; K := M × (M - 1) ÷ 2;
SYMMATVEC := VECVEC(L, if I ≤ U then I-1 else U, K, B, A)
+ SEQVEC(M, U, K + I, 0, A, B)
end SYMMATVEC;
comment ================== 31500 ================= ;
procedure FULMATVEC(LR, UR, LC, UC, A, B, C);
value LR, UR, LC, UC, B; integer LR, UR, LC, UC;
array A, B, C;
begin real procedure MATVEC(L, U, I, A, B); code 34011;
for LR := LR step 1 until UR do
C[LR] := MATVEC(LC, UC, LR, A, B);
end FULMATVEC;
comment ================== 31501 ================= ;
procedure FULTAMVEC(LR, UR, LC, UC, A, B, C);
value LR, UR, LC, UC, B; integer LR, UR, LC, UC;
array A, B, C;
begin real procedure TAMVEC(L, U, I, A, B); code 34012;
for LC := LC step 1 until UC do
C[LC] := TAMVEC(LR, UR, LC, A, B);
end FULTAMVEC;
comment ================== 31502 ================= ;
procedure FULSYMMATVEC(LR, UR, LC, UC, A, B, C);
value LR, UR, LC, UC, B; integer LR, UR, LC, UC;
array A, B, C;
begin real procedure SYMMATVEC(L, U, I, A, B);
code 34018;
for LR := LR step 1 until UR do
C[LR] := SYMMATVEC(LC, UC, LR, A, B)
end FULSYMMATVEC;
comment ================== 31503 ================= ;
procedure RESVEC(LR, UR, LC, UC, A, B, C, X);
value LR, UR, LC, UC, X; integer LR, UR, LC, UC;
real X; array A, B, C;
begin real procedure MATVEC(L, U, I, A, B); code 34011;
for LR := LR step 1 until UR do
C[LR] := MATVEC(LC, UC, LR, A, B) + C[LR] × X
end RESVEC;
comment ================== 31504 ================= ;
procedure SYMRESVEC(LR, UR, LC, UC, A, B, C, X);
value LR, UR, LC, UC, X; integer LR, UR, LC, UC;
real X; array A, B, C;
begin real procedure SYMMATVEC(L, U, I, A, B);
code 34018;
for LR := LR step 1 until UR do
C[LR] := SYMMATVEC(LC, UC, LR, A, B) + C[LR] × X
end SYMRESVEC;
comment ================== 34214 ================= ;
real procedure RNK1MIN(N, X, G, H, FUNCT, IN, OUT);
value N;
integer N; array X, G, H, IN, OUT;
real procedure FUNCT;
begin integer I, IT, N2, CNTL, CNTE, EVL, EVLMAX;
Boolean OK;
real F, F0, FMIN, MU, DG, DG0, GHG, GS, NRMDELTA, ALFA,
MACHEPS, RELTOL, ABSTOL, EPS, TOLG, ORTH, AID;
array V, DELTA, GAMMA, S, P[1:N];
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
real procedure MATVEC(L, U, I, A, B); code 34011;
real procedure TAMVEC(L, U, I, A, B); code 34012;
procedure ELMVEC(L, U, SHIFT, A, B, X); code 34020;
real procedure SYMMATVEC(L, U, I, A, B); code 34018;
procedure INIVEC(L, U, A, X); code 31010;
procedure INISYMD(LR, UR, SHIFT, A, X); code 31013;
procedure MULVEC(L, U, SHIFT, A, B, X); code 31020;
procedure DUPVEC(L, U, SHIFT, A, B); code 31030;
procedure EIGSYM1(A, N, NUMVAL, VAL, VEC, EM); code 34156;
procedure LINEMIN(N, X, D, ND, A, G, F, F0, F1, DFO, DF1,
E, S, IN); code 34210;
procedure RNK1UPD(H, N, V, C); code 34211;
procedure DAVUPD(H, N, V, W, C1, C2); code 34212;
procedure FLEUPD(H, N, V, W, C1, C2); code 34213;
MACHEPS := IN[0]; RELTOL := IN[1]; ABSTOL := IN[2];
MU := IN[3]; TOLG := IN[4]; FMIN := IN[5]; IT := 0;
ALFA := IN[6]; EVLMAX := IN[7]; ORTH := IN[8];
N2 := N × (N + 1) ÷ 2; CNTL := CNTE := 0; if ALFA > 0 then
begin INIVEC(1, N2, H, 0); INISYMD(1, N, 0, H, ALFA) end;
F := FUNCT(N, X, G); EVL := 1; DG := SQRT(VECVEC(1, N, 0, G, G));
for I := 1 step 1 until N do
DELTA[I] := - SYMMATVEC(1, N, I, H, G);
NRMDELTA := SQRT(VECVEC(1, N, 0, DELTA, DELTA));
DG0 := VECVEC(1, N, 0, DELTA, G); OK := DG0 < 0;
EPS := SQRT(VECVEC(1, N, 0, X, X)) × RELTOL + ABSTOL;
for IT := IT + 1 while
(NRMDELTA > EPS ∨ DG > TOLG ∨ ¬OK) ∧ EVL < EVLMAX
do
begin if ¬OK then
begin array VEC[1:N, 1:N], TH[1:N2], EM[0:9];
EM[0] := MACHEPS; EM[2] := AID := SQRT(MACHEPS × RELTOL);
EM[4] := ORTH; EM[6] := AID × N; EM[8] := 5;
CNTE := CNTE + 1; DUPVEC(1, N2, 0, TH, H);
EIGSYM1(TH, N, N, V, VEC, EM);
for I := 1 step 1 until N do
begin AID := - TAMVEC(1, N, I, VEC, G);
S[I] := AID × ABS(V[I]); V[I] := AID × SIGN(V[I])
end;
for I := 1 step 1 until N do
begin DELTA[I] := MATVEC(1, N, I, VEC, S);
P[I] := MATVEC(1, N, I, VEC, V)
end;
DG0 := VECVEC(1, N, 0, DELTA, G);
NRMDELTA := SQRT(VECVEC(1, N, 0, DELTA, DELTA))
end CALCULATING GREENSTADTS DIRECTION;
DUPVEC(1, N, 0, S, X); DUPVEC(1, N, 0, V, G);
if IT > N then ALFA := 1 else
begin if IT ≠ 1 then ALFA := ALFA / NRMDELTA else
begin ALFA := 2 × (FMIN - F) / DG0;
if ALFA > 1 then ALFA := 1
end
end;
ELMVEC(1, N, 0, X, DELTA, ALFA);
F0 := F; F := FUNCT(N, X, G); EVL := EVL + 1 ;
DG := VECVEC(1, N, 0, DELTA, G);
if IT = 1 ∨ F0 - F < -MU × DG0 × ALFA then
begin I := EVLMAX - EVL; CNTL := CNTL + 1 ;
LINEMIN(N, S, DELTA, NRMDELTA, ALFA, G, FUNCT, F0, F,
DG0, DG, I, false, IN); EVL := EVL + I;
DUPVEC(1, N, 0, X, S);
end LINEMINIMIZATION;
DUPVEC(1, N, 0, GAMMA, G); ELMVEC(1, N, 0, GAMMA, V, -1);
if ¬OK then MULVEC(1, N, 0, V, P, -1);
DG := DG - DG0; if ALFA ≠ 1 then
begin MULVEC(1, N, 0, DELTA, DELTA, ALFA);
MULVEC(1, N, 0, V, V, ALFA);
NRMDELTA := NRMDELTA × ALFA; DG := DG × ALFA
end;
DUPVEC(1, N, 0, P, GAMMA); ELMVEC(1, N, 0, P, V, 1);
for I := 1 step 1 until N do
V[I] := SYMMATVEC(1, N, I, H, GAMMA);
DUPVEC(1, N, 0, S, DELTA); ELMVEC(1, N, 0, S, V, -1);
GS := VECVEC(1, N, 0, GAMMA, S);
GHG := VECVEC(1, N, 0, V, GAMMA);
AID := DG / GS;
if VECVEC(1, N, 0, DELTA, P) ⭡ 2 > VECVEC(1, N, 0, P, P)
× (ORTH × NRMDELTA) ⭡ 2 then RNK1UPD(H, N, S, 1 / GS)
else if AID ≥ 0 then
FLEUPD(H, N, DELTA, V, 1 / DG, (1 + GHG / DG) / DG) else
DAVUPD(H, N, DELTA, V, 1 / DG, 1 / GHG);
for I := 1 step 1 until N do
DELTA[I] := -SYMMATVEC(1, N, I, H, G);
ALFA := NRMDELTA;
NRMDELTA := SQRT(VECVEC(1, N, 0, DELTA, DELTA));
EPS := SQRT(VECVEC(1, N, 0, X, X)) × RELTOL + ABSTOL;
DG := SQRT(VECVEC(1, N, 0, G, G));
DG0 := VECVEC(1, N, 0, DELTA, G); OK := DG0 ≤ 0
end ITERATION;
OUT[0] := NRMDELTA; OUT[1] := DG; OUT[2] := EVL;
OUT[3] := CNTL; OUT[4] := CNTE; RNK1MIN := F
end RNK1MIN;
comment ================== 34215 ================= ;
real procedure FLEMIN(N, X, G, H, FUNCT, IN, OUT);
value N;
integer N; array X, G, H, IN, OUT;
real procedure FUNCT;
begin integer I, IT, CNTL, EVL, EVLMAX;
real F, F0, FMIN, MU, DG, DG0, NRMDELTA, ALFA, RELTOL, ABSTOL,
EPS, TOLG, AID;
array V, DELTA, S[1:N];
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
procedure ELMVEC(L, U, SHIFT, A, B, X); code 34020;
real procedure SYMMATVEC(L, U, I, A, B); code 34018;
procedure INIVEC(L, U, A, X); code 31010;
procedure INISYMD(LR, UR, SHIFT, A, X); code 31013;
procedure MULVEC(L, U, SHIFT, A, B, XB); code 31020;
procedure DUPVEC(L, U, SHIFT, A, B); code 31030;
procedure LINEMIN(N, X, D, ND, A, G, F, F0, F1, DF0, DF1,
E, S, IN); code 34210;
procedure DAVUPD(H, N, V, W, C1, C2); code 34212;
procedure FLEUPD(H, N, V, W, C1, C2); code 34213;
RELTOL := IN[1]; ABSTOL := IN[2]; MU := IN[3];
TOLG := IN[4]; FMIN := IN[5]; ALFA := IN[6];
EVLMAX := IN[7]; OUT[4] := 0; IT := 0;
F := FUNCT(N, X, G); EVL := 1; CNTL := 0; if ALFA > 0 then
begin INIVEC(1, N × (N + 1) ÷ 2, H, 0);
INISYMD(1, N, 0, H, ALFA)
end;
for I := 1 step 1 until N do
DELTA[I] := - SYMMATVEC(1, N, I, H, G);
DG := SQRT(VECVEC(1, N, 0, G, G));
NRMDELTA := SQRT(VECVEC(1, N, 0, DELTA, DELTA));
EPS := SQRT(VECVEC(1, N, 0, X, X)) × RELTOL + ABSTOL;
DG0 := VECVEC(1, N, 0, DELTA, G);
for IT := IT + 1 while
(NRMDELTA > EPS ∨ DG > TOLG ) ∧ EVL < EVLMAX do
begin DUPVEC(1, N, 0, S, X); DUPVEC(1, N, 0, V, G);
if IT ≥ N then ALFA := 1 else
begin if IT ≠ 1 then ALFA := ALFA / NRMDELTA else
begin ALFA := 2 × (FMIN - F) / DG0;
if ALFA > 1 then ALFA := 1
end
end;
ELMVEC(1, N, 0, X, DELTA, ALFA);
F0 := F; F := FUNCT(N, X, G); EVL := EVL + 1 ;
DG := VECVEC(1, N, 0, DELTA, G);
if IT = 1 ∨ F0 - F < - MU × DG0 × ALFA then
begin I := EVLMAX - EVL; CNTL := CNTL + 1 ;
LINEMIN(N, S, DELTA, NRMDELTA, ALFA, G, FUNCT, F0, F,
DG0, DG, I, false, IN); EVL := EVL + I;
DUPVEC(1, N, 0, X, S);
end LINEMINIMIZATION;
if ALFA ≠ 1 then MULVEC(1, N, 0, DELTA, DELTA, ALFA);
MULVEC(1, N, 0, V, V, -1); ELMVEC(1, N, 0, V, G, 1);
for I := 1 step 1 until N do
S[I] := SYMMATVEC(1, N, I, H, V);
AID := VECVEC(1, N, 0, V, S); DG := (DG - DG0) × ALFA;
if DG > 0 then
begin if DG ≥ AID then
FLEUPD(H, N, DELTA, S, 1 / DG, (1 + AID / DG) / DG)
else DAVUPD(H, N, DELTA, S, 1 / DG, 1 / AID)
end UPDATING;
for I := 1 step 1 until N do
DELTA[I] := -SYMMATVEC(1, N, I, H, G);
ALFA := NRMDELTA × ALFA;
NRMDELTA := SQRT(VECVEC(1, N, 0, DELTA, DELTA));
EPS := SQRT(VECVEC(1, N, 0, X, X)) × RELTOL + ABSTOL;
DG := SQRT(VECVEC(1, N, 0, G, G));
DG0 := VECVEC(1, N, 0, DELTA, G); if DG0 > 0 then
begin OUT[4] := -1 ; goto EXIT end
end ITERATION;
EXIT: OUT[0] := NRMDELTA; OUT[1] := DG; OUT[2] := EVL;
OUT[3] := CNTL; FLEMIN := F
end FLEMIN;
comment ================== 34352 ================= ;
procedure COMCOLCST(L, U, J, AR, AI, XR, XI);
value L, U, J, XR, XI; integer L, U, J; real XR, XI;
array AR, AI;
begin
procedure COMMUL(AR, AI, BR, BI, RR, RI); code 34341;
for L := L step 1 until U do
COMMUL(AR[L, J], AI[L, J], XR, XI, AR[L, J], AI[L, J]);
end COMCOLCST;
comment ================== 34353 ================= ;
procedure COMROWCST(L, U, I, AR, AI, XR, XI);
value L, U, I, XR, XI; integer L, U, I; real XR, XI;
array AR, AI;
begin
procedure COMMUL(AR, AI, BR, BI, RR, RI); code 34341;
for L := L step 1 until U do COMMUL(AR[I, L], AI[I, L], XR,
XI, AR[I, L], AI[I, L]);
end COMROWCST;
comment ================== 34354 ================= ;
procedure COMMATVEC(L, U, I, AR, AI, BR, BI, RR, RI);
value L, U, I; integer L, U, I; real RR, RI;
array AR, AI, BR, BI;
begin real procedure MATVEC(L, U, I, A, B); code 34011;
real MV;
MV := MATVEC(L, U, I, AR, BR) - MATVEC(L, U, I, AI, BI);
RI := MATVEC(L, U, I, AI, BR) + MATVEC(L, U, I, AR, BI);
RR := MV
end COMMATVEC;
comment ================== 34355 ================= ;
Boolean procedure HSHCOMCOL(L, U, J, AR, AI, TOL, K, C, S, T);
value L, U, J, TOL; integer L, U, J; real TOL, K, C, S, T;
array AR, AI;
begin real VR, DEL, MOD, H, ARLJ, AILJ;
procedure CARPOL(AR, AI, R, C, S); code 34344;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
VR := TAMMAT(L + 1, U, J, J, AR, AR) + TAMMAT(L + 1, U,
J, J, AI, AI); ARLJ := AR[L, J]; AILJ := AI[L, J];
CARPOL(ARLJ, AILJ, MOD, C, S); if VR > TOL then
begin VR := VR + ARLJ ⭡ 2 + AILJ ⭡ 2; H := K := SQRT(VR);
T := VR + MOD × H;
if ARLJ = 0 ∧ AILJ = 0 then AR[L, J] := H else
begin AR[L, J] := ARLJ + C × K; AI[L, J] := AILJ + S × K;
S := - S
end;
C := - C; HSHCOMCOL := true
end
else
begin HSHCOMCOL := false; K := MOD; T := - 1 end
end HSHCOMCOL;
comment ================== 34356 ================= ;
procedure HSHCOMPRD(I, II, L, U, J, AR, AI, BR, BI, T);
value I, II, L, U, J, T; integer I, II, L, U, J; real T;
array AR, AI, BR, BI;
begin
procedure ELMCOMCOL(L, U, I, J, AR, AI, BR, BI, XR, XI); code 34377;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
for L := L step 1 until U do ELMCOMCOL(I, II, L, J, AR, AI,
BR, BI, ( - TAMMAT(I, II, J, L, BR, AR) - TAMMAT(I, II, J,
L, BI, AI)) / T, (TAMMAT(I, II, J, L, BI, AR) - TAMMAT(I,
II, J, L, BR, AI)) / T);
end HSHCOMPRD;
comment ================== 34376 ================= ;
procedure ELMCOMVECCOL(L, U, J, AR, AI, BR, BI, XR, XI);
value L, U, J, XR, XI;
integer L, U, J; real XR, XI; array AR, AI, BR, BI;
begin
procedure ELMVECCOL(L, U, I, A, B, X); code 34021;
ELMVECCOL(L, U, J, AR, BR, XR);
ELMVECCOL(L, U, J, AR, BI, -XI);
ELMVECCOL(L, U, J, AI, BR, XI);
ELMVECCOL(L, U, J, AI, BI, XR)
end ELMCOMVECCOL;
comment ================== 34377 ================= ;
procedure ELMCOMCOL(L, U, I, J, AR, AI, BR, BI, XR, XI);
value L, U, I, J, XR, XI;
integer L, U, I, J; real XR, XI; array AR, AI, BR, BI;
begin
procedure ELMCOL(L, U, I, J, A, B, X); code 34023;
ELMCOL(L, U, I, J, AR, BR, XR);
ELMCOL(L, U, I, J, AR, BI, -XI);
ELMCOL(L, U, I, J, AI, BR, XI);
ELMCOL(L, U, I, J, AI, BI, XR)
end ELMCOMCOL;
comment ================== 34378 ================= ;
procedure ELMCOMROWVEC(L, U, I, AR, AI, BR, BI, XR, XI);
value L, U, I, XR, XI;
integer L, U, I; real XR, XI; array AR, AI, BR, BI;
begin
procedure ELMROWVEC(L, U, I, A, B, X); code 34027;
ELMROWVEC(L, U, I, AR, BR, XR);
ELMROWVEC(L, U, I, AR, BI, -XI);
ELMROWVEC(L, U, I, AI, BR, XI);
ELMROWVEC(L, U, I, AI, BI, XR)
end ELMCOMROWVEC;
comment ================== 34360 ================= ;
procedure SCLCOM(AR, AI, N, N1, N2); value N, N1, N2;
integer N, N1, N2; array AR, AI;
begin integer I, J, K;
real S, R;
procedure COMCOLCST(L, U, J, AR, AI, XR, XI); code 34352;
for J := N1 step 1 until N2 do
begin S := 0;
for I := 1 step 1 until N do
begin R := AR[I, J] ⭡ 2 + AI[I, J] ⭡ 2; if R > S then
begin S := R; K := I end
end;
if S ≠ 0 then COMCOLCST(1, N, J, AR, AI, AR[K, J] /
S, - AI[K, J] / S)
end
end SCLCOM;
comment ================== 34359 ================= ;
real procedure COMEUCNRM(AR, AI, LW, N); value N, LW;
integer N, LW; array AR, AI;
begin integer I, L;
real procedure MATTAM(L, U, I, J, A, B); code 34015;
real R;
R := 0;
for I := 1 step 1 until N do
begin L := if I > LW then I - LW else 1;
R := MATTAM(L, N, I, I, AR, AR) + MATTAM(L, N, I,
I, AI, AI) + R;
end;
COMEUCNRM := SQRT(R)
end COMEUCNRM;
comment ================== 34340 ================= ;
real procedure COMABS(XR, XI); value XR, XI; real XR, XI;
begin XR := ABS(XR); XI := ABS(XI);
COMABS := if XI > XR then SQRT((XR/XI)⭡2 + 1) × XI
else if XI = 0 then XR else SQRT((XI/XR)⭡2 + 1) × XR
end COMABS;
comment ================== 34343 ================= ;
procedure COMSQRT(AR, AI, PR, PI);
value AR, AI; real AR, AI, PR, PI;
if AR = 0 ∧ AI = 0 then PR := PI := 0 else
begin real BR, BI, H;
BR := ABS(AR); BI := ABS(AI);
H := if BI < BR then
(if BR < 1 then SQRT((SQRT((BI/BR)⭡2 + 1) × .5 + .5) × BR)
else SQRT((SQRT((BI/BR)⭡2 + 1) × .125 + .125) × BR) × 2)
else if BI < 1 then SQRT((SQRT((BR/BI)⭡2 + 1) × BI + BR) × 2) × .5
else if BR + 1 = 1 then SQRT(BI × .5)
else SQRT(SQRT((BR/BI)⭡2 + 1) × BI × .125 + BR × .125) × 2;
if AR ≥ 0 then
begin PR := H; PI := AI/H × .5 end
else begin PI := if AI ≥ 0 then H else -H;
PR := BI/H × .5
end
end COMSQRT;
comment ================== 34342 ================= ;
procedure COMDIV(XR, XI, YR, YI, ZR, ZI);
value XR, XI, YR, YI; real XR, XI, YR, YI, ZR, ZI;
begin real H, D;
if ABS(YI) < ABS(YR) then
begin if YI = 0 then
begin ZR := XR/YR; ZI := XI/YR end else
begin H := YI/YR; D := H × YI + YR;
ZR := (XR + H × XI)/D; ZI := (XI-H × XR)/D
end
end else
begin H := YR/YI; D := H × YR + YI;
ZR := (XR × H + XI)/D; ZI := (XI × H - XR)/D
end
end COMDIV;
comment ================== 34301 ================= ;
procedure DECSOL(A, N, AUX, B); value N; integer N;
array A, AUX, B;
begin integer array P[1:N];
procedure SOL(A, N, P, B); code 34051;
procedure DEC(A, N, AUX, P); code 34300;
DEC(A, N, AUX, P);
if AUX[3] = N then SOL(A, N, P, B)
end DECSOL;
comment ================== 34061 ================= ;
procedure SOLELM(A, N, RI, CI, B); value N; integer N;
array A, B;
integer array RI, CI;
begin integer R, CIR;
real W;
procedure SOL(A, N, P, B); code 34051;
SOL(A, N, RI, B);
for R := N step - 1 until 1 do
begin CIR := CI[R]; if CIR ≠ R then
begin W := B[R]; B[R] := B[CIR]; B[CIR] := W end
end
end SOLELM;
comment ================== 34243 ================= ;
procedure GSSSOLERB(A, N, AUX, B); value N; integer N;
array A, AUX, B;
begin integer array RI, CI[1:N];
procedure SOLELM(A, N, RI, CI, B); code 34061;
procedure GSSERB(A, N, AUX, RI, CI); code 34242;
GSSERB(A, N, AUX, RI, CI);
if AUX[3] = N then SOLELM(A, N, RI, CI, B)
end GSSSOLERB;
comment ================== 34302 ================= ;
procedure DECINV(A, N, AUX); value N; integer N;
array A, AUX;
begin integer array P[1:N];
procedure DEC(A, N, AUX, P); code 34300;
procedure INV(A, N, P); code 34053;
DEC(A, N, AUX, P); if AUX[3] = N then INV(A, N, P)
end DECINV;
comment ================== 34236 ================= ;
procedure GSSINV(A, N, AUX); value N; integer N;
array A, AUX;
begin integer array RI, CI[1:N];
procedure GSSELM(A, N, AUX, RI, CI); code 34231;
real procedure INV1(A, N, RI, CI, WITHNORM); code 34235;
GSSELM(A, N, AUX, RI, CI);
if AUX[3] = N then AUX[9] := INV1(A, N, RI, CI, true)
end GSSINV;
comment ================== 34244 ================= ;
procedure GSSINVERB(A, N, AUX); value N; integer N;
array A, AUX;
begin integer array RI, CI[1:N];
procedure GSSELM(A, N, AUX, RI, CI); code 34231;
real procedure INV1(A, N, RI, CI, WITHNORM); code 34235;
procedure ERBELM(N, AUX, NRMINV); code 34241;
GSSELM(A, N, AUX, RI, CI);
if AUX[3] = N then
ERBELM(N, AUX, INV1(A, N, RI, CI, true))
end GSSINVERB;
comment ================== 34251 ================= ;
procedure GSSITISOL(A, N, AUX, B); value N; integer N;
array A, AUX, B;
begin integer I, J;
array AA[1:N, 1:N];
integer array RI, CI[1:N];
procedure GSSELM(A, N, AUX, RI, CI); code 34231;
procedure ITISOL(A, LU, N, AUX, RI, CI, B); code 34250;
procedure DUPMAT(L, U, I, J, A, B); code 31035;
DUPMAT(1, N, 1, N, AA, A);
GSSELM(A, N, AUX, RI, CI);
if AUX[3] = N then ITISOL(AA, A, N, AUX, RI, CI, B)
end GSSITISOL;
comment ================== 34254 ================= ;
procedure GSSITISOLERB(A, N, AUX, B); value N; integer N;
array A, AUX, B;
begin integer I, J;
array AA[1:N, 1:N];
integer array RI, CI[1:N];
procedure GSSNRI(A, N, AUX, RI, CI); code 34252;
procedure ITISOLERB(A, LU, N, AUX, RI, CI, B); code 34253;
procedure DUPMAT(L, U, I, J, A, B); code 31035;
DUPMAT(1, N, 1, N, AA, A);
GSSNRI(A, N, AUX, RI, CI);
if AUX[3] = N then ITISOLERB(AA, A, N, AUX, RI, CI, B)
end GSSITISOLERB;
comment ================== 34131 ================= ;
procedure LSQSOL(A, N, M, AID, CI, B); value N, M;
integer N, M; array A, AID, B; integer array CI;
begin integer K, CIK;
real W;
real procedure MATVEC(L, U, I, A, B); code 34011;
real procedure TAMVEC(L, U, I, A, B); code 34012;
procedure ELMVECCOL(L, U, I, A, B, X); code 34021;
for K := 1 step 1 until M do ELMVECCOL(K, N, K, B, A,
TAMVEC(K, N, K, A, B) / (AID[K] × A[K, K]));
for K := M step - 1 until 1 do B[K] := (B[K] - MATVEC
(K + 1, M, K, A, B)) / AID[K];
for K := M step - 1 until 1 do
begin CIK := CI[K]; if CIK ≠ K then
begin W := B[K]; B[K] := B[CIK]; B[CIK] := W end
end
end LSQSOL;
comment ================== 34135 ================= ;
procedure LSQORTDECSOL(A, N, M, AUX, DIAG, B); value N, M;
integer N, M; array A, AUX, DIAG, B;
begin array AID[1:M];
integer array CI[1:M];
procedure LSQORTDEC(A, N, M, AUX, AID, CI); code 34134;
procedure LSQDGLINV(A, M, AID, CI, DIAG); code 34132;
procedure LSQSOL(A, N, M, AID, CI, B); code 34131;
LSQORTDEC(A, N, M, AUX, AID, CI);
if AUX[3] = M then
begin LSQDGLINV(A, M, AID, CI, DIAG);
LSQSOL(A, N, M, AID, CI, B)
end
end LSQORTDECSOL;
comment ================== 34280 ================= ;
procedure SOLSVDOVR(U, VAL, V, M, N, X, EM);
value M, N; integer M, N; array U, VAL, V, X, EM;
begin integer I;
real MIN;
array X1[1:N];
real procedure MATVEC(L, U, I, A, B);
value L, U, I; integer L, U, I; array A, B;
code 34011;
real procedure TAMVEC(L, U, I, A, B);
value L, U, I; integer L, U, I; array A, B;
code 34012;
MIN := EM[6];
for I := 1 step 1 until N do
X1[I] := if VAL[I] ≤ MIN then 0 else TAMVEC(1, M, I, U, X) /
VAL[I];
for I := 1 step 1 until N do
X[I] := MATVEC(1, N, I, V, X1)
end SOLSVDOVR;
comment ================== 34281 ================= ;
integer procedure SOLOVR(A, M, N, X, EM);
value M, N; integer M, N; array A, X, EM;
begin integer I;
array VAL[1:N], V[1:N, 1:N];
integer procedure QRISNGVALDEC(A, M, N, VAL, V, EM);
value M, N; integer M, N; array A, VAL, V, EM;
code 34273;
procedure SOLSVDOVR(U, VAL, V, M, N, X, EM);
value M, N; integer M, N; array U, VAL, V, X, EM;
code 34280;
SOLOVR := I := QRISNGVALDEC(A, M, N, VAL, V, EM);
if I = 0 then SOLSVDOVR(A, VAL, V, M, N, X, EM)
end SOLOVR;
comment ================== 34282 ================= ;
procedure SOLSVDUND(U, VAL, V, M, N, X, EM);
value M, N; integer M, N; array U, VAL, V, X, EM;
begin integer I;
real MIN;
array X1[1:N];
real procedure MATVEC(L, U, I, A, B);
value L, U, I; integer L, U, I; array A, B;
code 34011;
real procedure TAMVEC(L, U, I, A, B);
value L, U, I; integer L, U, I; array A, B;
code 34012;
MIN := EM[6];
for I := 1 step 1 until N do
X1[I] := if VAL[I] ≤ MIN then 0 else TAMVEC(1, N, I, V, X) /
VAL[I];
for I := 1 step 1 until M do
X[I] := MATVEC(1, N, I, U, X1)
end SOLSVDUND;
comment ================== 34283 ================= ;
integer procedure SOLUND(A, M, N, X, EM);
value M, N; integer M, N; array A, X, EM;
begin integer I;
array VAL[1:N], V[1:N, 1:N];
integer procedure QRISNGVALDEC(A, M, N, VAL, V, EM);
value M, N; integer M, N; array A, VAL, V, EM;
code 34273;
procedure SOLSVDUND(U, VAL, V, M, N, X, EM);
value M, N; integer M, N; array U, VAL, V, X, EM;
code 34282;
SOLUND := I := QRISNGVALDEC(A, M, N, VAL, V, EM);
if I = 0 then SOLSVDUND(A, VAL, V, M, N, X, EM)
end SOLUND;
comment ================== 34285 ================= ;
integer procedure HOMSOL(A, M, N, V, EM);
value M, N; integer M, N; array A, V, EM;
begin integer I;
array VAL[1:N];
integer procedure QRISNGVALDEC(A, M, N, VAL, V, EM);
value M, N; integer M, N; array A, VAL, V, EM;
code 34273;
procedure HOMSOLSVD(U, VAL, V, M, N);
value M, N; integer M, N; array U, VAL, V;
code 34284;
HOMSOL := I := QRISNGVALDEC(A, M, N, VAL, V, EM);
if I = 0 then HOMSOLSVD(A, VAL, V, M, N)
end HOMSOL;
comment ================== 34286 ================= ;
procedure PSDINVSVD(U, VAL, V, M, N, EM);
value M, N; integer M, N; array U, VAL, V, EM;
begin integer I, J;
real MIN, VALI;
array X[1:N];
real procedure MATVEC(L, U, I, A, B);
value L, U, I; integer L, U, I; array A, B;
code 34011;
MIN := EM[6];
for I := 1 step 1 until N do
if VAL[I] > MIN then
begin VALI := 1 / VAL[I];
for J := 1 step 1 until M do U[J, I] := U[J, I] × VALI
end
else for J := 1 step 1 until M do U[J, I] := 0;
for I := 1 step 1 until M do
begin for J := 1 step 1 until N do X[J] := U[I, J];
for J := 1 step 1 until N do
U[I, J] := MATVEC(1, N, J, V, X)
end
end PSDINVSVD;
comment ================== 34287 ================= ;
integer procedure PSDINV(A, M, N, EM);
value M, N; integer M, N; array A, EM;
begin integer I;
array VAL[1:N], V[1:N, 1:N];
integer procedure QRISNGVALDEC(A, M, N, VAL, V, EM);
value M, N; integer M, N; array A, VAL, V, EM;
code 34273;
procedure PSDINVSVD(U, VAL, V, M, N, EM);
value M, N; integer M, N; array U, VAL, V, EM;
code 34286;
PSDINV := I := QRISNGVALDEC(A, M, N, VAL, V, EM);
if I = 0 then PSDINVSVD(A, VAL, V, M, N, EM)
end PSDINV;
comment ================== 34320 ================= ;
procedure DECBND(A, N, LW, RW, AUX, M, P); value N, LW, RW;
integer N, LW, RW; integer array P; array A, M, AUX;
begin integer I, J, K, KK, KK1, PK, MK, IK, LW1, F, Q, W, W1,
W2, NRW, IW, SDET;
real R, S, EPS, MIN;
array V[1:N];
real procedure VECVEC(A, B, C, D, E); code 34010;
procedure ELMVEC(A, B, C, D, E, F); code 34020;
procedure ICHVEC(A, B, C, D); code 34030;
F := LW; W1 := LW + RW; W := W1 + 1; W2 := W - 2; IW := 0; SDET := 1;
NRW := N - RW; LW1 := LW + 1; Q := LW - 1;
for I := 2 step 1 until LW do
begin Q := Q - 1; IW := IW + W1;
for J := IW - Q step 1 until IW do A[J] := 0
end;
IW := - W2; Q := - LW;
for I := 1 step 1 until N do
begin IW := IW + W; if I ≤ LW1 then IW := IW - 1;
Q := Q + W; if I > NRW then Q := Q - 1;
V[I] := SQRT(VECVEC(IW, Q, 0, A, A))
end;
EPS := AUX[2]; MIN := 1; KK := - W1; MK := - LW;
if F > NRW then W2 := W2 + NRW - F;
for K := 1 step 1 until N do
begin if F < N then F := F + 1; IK := KK := KK + W;
MK := MK + LW; S := ABS(A[KK]) / V[K]; PK := K; KK1 := KK + 1;
for I := K + 1 step 1 until F do
begin IK := IK + W1; M[MK + I - K] := R := A[IK]; A[IK] := 0;
R := ABS(R) / V[I]; if R > S then
begin S := R; PK := I end
end;
if S < MIN then MIN := S; if S < EPS then
begin AUX[3] := K - 1; AUX[5] := S; go to END end;
if K + W2 ≥ N then W2 := W2 - 1;
P[K] := PK; if PK ≠ K then
begin V[PK] := V[K];
PK := PK - K; ICHVEC(KK1, KK1 + W2, PK × W1, A);
SDET := - SDET; R := M[MK + PK]; M[MK + PK] := A[KK];
A[KK] := R
end else R := A[KK]; if R < 0 then SDET := - SDET;
IW := KK1; LW1 := F - K + MK;
for I := MK + 1 step 1 until LW1 do
begin M[I] := S := M[I] / R; IW := IW + W1;
ELMVEC(IW, IW + W2, KK1 - IW, A, A, - S)
end
end;
AUX[3] := N; AUX[5] := MIN;
END: AUX[1] := SDET
end DECBND;
comment ================== 34321 ================= ;
real procedure DETERMBND(A, N, LW, RW, SGNDET);
value N, LW, RW, SGNDET; integer N, LW, RW, SGNDET; array A;
begin integer I, L; real P;
L := 1; P := 1; LW := LW + RW + 1;
for I := 1 step 1 until N do
begin P := A[L] × P; L := L + LW end;
DETERMBND := ABS(P) × SGNDET
end DETERMBND;
comment ================== 34071 ================= ;
procedure SOLBND(A, N, LW, RW, M, P, B); value N, LW, RW;
integer N, LW, RW; integer array P; array A, B, M;
begin integer F, I, K, KK, W, W1, W2, SHIFT;
real S;
real procedure VECVEC(A, B, C, D, E); code 34010;
procedure ELMVEC(A, B, C, D, E, F); code 34020;
F := LW; SHIFT := - LW; W1 := LW - 1;
for K := 1 step 1 until N do
begin if F < N then F := F + 1; SHIFT := SHIFT + W1;
I := P[K]; S := B[I]; if I ≠ K then
begin B[I] := B[K]; B[K] := S end;
ELMVEC(K + 1, F, SHIFT, B, M, - S)
end;
W1 := LW + RW; W := W1 + 1; KK := (N + 1) × W - W1; W2 := - 1;
SHIFT := N × W1;
for K := N step - 1 until 1 do
begin KK := KK - W; SHIFT := SHIFT - W1;
if W2 < W1 then W2 := W2 + 1;
B[K] := (B[K] - VECVEC(K + 1, K + W2, SHIFT, B, A)) / A[KK]
end
end SOLBND;
comment ================== 34322 ================= ;
procedure DECSOLBND(A, N, LW, RW, AUX, B); value N, LW, RW;
integer N, LW, RW; array A, B, AUX;
begin integer I, J, K, KK, KK1, PK, IK, LW1, F, Q, W, W1, W2, IW,
NRW, SHIFT, SDET;
real R, S, EPS, MIN; array M[0:LW], V[1:N];
real procedure VECVEC(A, B, C, D, E); code 34010;
procedure ELMVEC(A, B, C, D, E, F); code 34020;
procedure ICHVEC(A, B, C, D); code 34030;
F := LW; SDET := 1; W1 := LW + RW; W := W1 + 1; W2 := W - 2; IW := 0;
NRW := N - RW; LW1 := LW + 1; Q := LW - 1;
for I := 2 step 1 until LW do
begin Q := Q - 1; IW := IW + W1;
for J := IW - Q step 1 until IW do A[J] := 0
end;
IW := - W2; Q := - LW;
for I := 1 step 1 until N do
begin IW := IW + W; if I ≤ LW1 then IW := IW - 1;
Q := Q + W; if I > NRW then Q := Q - 1;
V[I] := SQRT(VECVEC(IW, Q, 0, A, A))
end;
EPS := AUX[2]; MIN := 1; KK := - W1;
if F > NRW then W2 := W2 + NRW - F;
for K := 1 step 1 until N do
begin if F < N then F := F + 1; IK := KK := KK + W;
S := ABS(A[KK]) / V[K]; PK := K; KK1 := KK + 1;
for I := K + 1 step 1 until F do
begin IK := IK + W1; M[I - K] := R := A[IK]; A[IK] := 0;
R := ABS(R) / V[I]; if R > S then
begin S := R; PK := I end
end;
if S < MIN then MIN := S; if S < EPS then
begin AUX[3] := K - 1; AUX[5] := S; go to END end;
if K + W2 ≥ N then W2 := W2 - 1; if PK ≠ K then
begin V[PK] := V[K];
PK := PK - K; ICHVEC(KK1, KK1 + W2, PK × W1, A);
SDET := - SDET; R := B[K]; B[K] := B[PK + K];
B[PK + K] := R; R := M[PK]; M[PK] := A[KK]; A[KK] := R
end
else R := A[KK]; IW := KK1; LW1 := F - K;
if R < 0 then SDET := - SDET;
for I := 1 step 1 until LW1 do
begin M[I] := S := M[I] / R; IW := IW + W1;
ELMVEC(IW, IW + W2, KK1 - IW, A, A, - S);
B[K + I] := B[K + I] - B[K] × S
end
end;
AUX[3] := N; AUX[5] := MIN;
KK := (N + 1) × W - W1; W2 := - 1; SHIFT := N × W1;
for K := N step - 1 until 1 do
begin KK := KK - W; SHIFT := SHIFT - W1;
if W2 < W1 then W2 := W2 + 1;
B[K] := (B[K] - VECVEC(K + 1, K + W2, SHIFT, B, A)) / A[KK]
end;
END: AUX[1] := SDET
end DECSOLBND;
comment ================== 34423 ================= ;
procedure DECTRI(SUB, DIAG, SUPER, N, AUX);
value N; integer N; array SUB, DIAG, SUPER, AUX;
begin integer I, N1;
real D, R, S, U, NORM, NORM1, TOL;
TOL := AUX[2]; D := DIAG[1]; R := SUPER[1];
NORM := NORM1 := ABS(D) + ABS(R);
if ABS(D) ≤ NORM1 × TOL then
begin AUX[3] := 0; AUX[5] := D; goto EXIT end;
U := SUPER[1] := R / D; S := SUB[1]; N1 := N - 1;
for I := 2 step 1 until N1 do
begin D := DIAG[I]; R := SUPER[I];
NORM1 := ABS(S) + ABS(D) + ABS(R);
D := DIAG[I] := D - U × S;
if ABS(D) ≤ NORM1 × TOL then
begin AUX[3] := I - 1; AUX[5] := D; goto EXIT end;
U := SUPER[I] := R / D; S := SUB[I];
if NORM1 > NORM then NORM := NORM1
end;
D := DIAG[N]; NORM1 := ABS(D) + ABS(S);
D := DIAG[N] := D - U × S;
if ABS(D) ≤ NORM1 × TOL then
begin AUX[3] := N1; AUX[5] := D; goto EXIT end;
if NORM1 > NORM then NORM := NORM1;
AUX[3] := N; AUX[5] := NORM;
EXIT:
end DECTRI;
comment ================== 34426 ================= ;
procedure DECTRIPIV(SUB, DIAG, SUPER, N, AID, AUX, PIV);
value N; integer N; array SUB, DIAG, SUPER, AID, AUX;
Boolean array PIV;
begin integer I, I1, N1, N2;
real D, R, S, U, T, Q, V, W, NORM, NORM1, NORM2, TOL;
TOL := AUX[2]; D := DIAG[1]; R := SUPER[1];
NORM := NORM2 := ABS(D) + ABS(R); N2 := N - 2;
for I := 1 step 1 until N2 do
begin I1 := I + 1; S := SUB[I]; T := DIAG[I1]; Q := SUPER[I1];
NORM1 := NORM2; NORM2 := ABS(S) + ABS(T) + ABS(Q);
if NORM2 > NORM then NORM := NORM2;
if ABS(D) × NORM2 < ABS(S) × NORM1 then
begin if ABS(S) ≤ TOL × NORM2 then
begin AUX[3] := I - 1; AUX[5] := S; goto EXIT end;
DIAG[I] := S; U := SUPER[I] := T / S;
V := AID[I] := Q / S; SUB[I] := D;
W := SUPER[I1] := -V × D; D := DIAG[I1] := R - U × D;
R := W; NORM2 := NORM1; PIV[I] := true
end else
begin if ABS(D) ≤ TOL × NORM1 then
begin AUX[3] := I - 1; AUX[5] := D; goto EXIT end;
U := SUPER[I] := R / D; D := DIAG[I1] := T - U × S;
AID[I] := 0; PIV[I] := false; R := Q
end
end;
N1 := N - 1; S := SUB[N1]; T := DIAG[N]; NORM1 := NORM2;
NORM2 := ABS(S) + ABS(T); if NORM2 > NORM then NORM := NORM2;
if ABS(D) × NORM2 < ABS(S) × NORM1 then
begin if ABS(S) ≤ TOL × NORM2 then
begin AUX[3] := N2; AUX[5] := S; goto EXIT end;
DIAG[N1] := S; U := SUPER[N1] := T / S; SUB[N1] := D;
D := DIAG[N] := R - U × D; NORM2 := NORM1; PIV[N1] := true
end else
begin if ABS(D) ≤ TOL × NORM1 then
begin AUX[3] := N2; AUX[5] := D; goto EXIT end;
U := SUPER[N1] := R / D; D := DIAG[N] := T - U × S;
PIV[N1] := false
end;
if ABS(D) ≤ TOL × NORM2 then
begin AUX[3] := N1; AUX[5] := D; goto EXIT end;
AUX[3] := N; AUX[5] := NORM;
EXIT:
end DECTRIPIV;
comment ================== 34424 ================= ;
procedure SOLTRI(SUB, DIAG, SUPER, N, B);
value N; integer N; array SUB, DIAG, SUPER, B;
begin integer I;
real R;
R := B[1] := B[1] / DIAG[1];
for I := 2 step 1 until N do
R := B[I] := (B[I] - SUB[I - 1] × R) / DIAG[I];
for I := N - 1 step -1 until 1 do
R := B[I] := B[I] - SUPER[I] × R
end SOLTRI;
comment ================== 34425 ================= ;
procedure DECSOLTRI(SUB, DIAG, SUPER, N, AUX, B);
value N; integer N; array SUB, DIAG, SUPER, AUX, B;
begin procedure DECTRI(SUB, DIAG, SUPER, N, AUX); code 34423;
procedure SOLTRI( SUB, DIAG, SUPER, N, B); code 34424;
DECTRI(SUB, DIAG, SUPER, N, AUX); if AUX[3] = N then
SOLTRI(SUB, DIAG, SUPER, N, B)
end DECSOLTRI;
comment ================== 34427 ================= ;
procedure SOLTRIPIV(SUB, DIAG, SUPER, N, AID, PIV, B);
value N; integer N; array SUB, DIAG, SUPER, AID, B;
Boolean array PIV;
begin integer I, N1;
real BI, BI1, R, S, T;
N1 := N - 1;
for I := 1 step 1 until N1 do
begin if PIV[I] then
begin BI := B[I + 1]; BI1 := B[I] end
else
begin BI := B[I]; BI1 := B[I + 1] end;
R := B[I] := BI / DIAG[I];
B[I + 1] := BI1 - SUB[I] × R
end;
R := B[N] := B[N] / DIAG[N];
T := B[N1] := B[N1] - SUPER[N1] × R;
for I := N - 2 step -1 until 1 do
begin S := R; R := T; T := B[I] := B[I] - SUPER[I] × R -
(if PIV[I] then AID[I] × S else 0)
end
end SOLTRIPIV;
comment ================== 34428 ================= ;
procedure DECSOLTRIPIV(SUB, DIAG, SUPER, N, AUX, B);
value N; integer N; array SUB, DIAG, SUPER, AUX, B;
begin integer I, I1, N1, N2;
real D, R, S, U, T, Q, V, W, NORM, NORM1, NORM2, TOL,
BI, BI1, BI2;
Boolean array PIV[1:N];
TOL := AUX[2]; D := DIAG[1]; R := SUPER[1]; BI := B[1];
NORM := NORM2 := ABS(D) + ABS(R); N2 := N - 2;
for I := 1 step 1 until N2 do
begin I1 := I + 1; S := SUB[I]; T := DIAG[I1]; Q := SUPER[I1];
BI1 := B[I1];
NORM1 := NORM2; NORM2 := ABS(S) + ABS(T) + ABS(Q);
if NORM2 > NORM then NORM := NORM2;
if ABS(D) × NORM2 < ABS(S) × NORM1 then
begin if ABS(S) ≤ TOL × NORM2 then
begin AUX[3] := I - 1; AUX[5] := S; goto EXIT end;
U := SUPER[I] := T / S; BI1 := B[I] := BI1 / S;
BI := BI - BI1 × D; V := SUB[I] := Q / S;
W := SUPER[I1] := -V × D; D := DIAG[I1] := R - U × D;
R := W; NORM2 := NORM1; PIV[I] := true
end else
begin if ABS(D) ≤ TOL × NORM1 then
begin AUX[3] := I - 1; AUX[5] := D; goto EXIT end;
U := SUPER[I] := R / D; BI := B[I] := BI / D;
BI := BI1 - BI × S; D := DIAG[I1] := T - U × S;
PIV[I] := false; R := Q
end
end;
N1 := N - 1; S := SUB[N1]; T := DIAG[N]; NORM1 := NORM2; BI1 := B[N];
NORM2 := ABS(S) + ABS(T); if NORM2 > NORM then NORM := NORM2;
if ABS(D) × NORM2 < ABS(S) × NORM1 then
begin if ABS(S) ≤ TOL × NORM2 then
begin AUX[3] := N2; AUX[5] := S; goto EXIT end;
U := SUPER[N1] := T / S; BI1 := B[N1] := BI1 / S;
BI := BI - BI1 × D; D := R - U × D; NORM2 := NORM1
end else
begin if ABS(D) ≤ TOL × NORM1 then
begin AUX[3] := N2; AUX[5] := D; goto EXIT end;
U := SUPER[N1] := R / D; BI := B[N1] := BI / D;
BI := BI1 - BI × S; D := T - U × S
end;
if ABS(D) ≤ TOL × NORM2 then
begin AUX[3] := N1; AUX[5] := D; goto EXIT end;
AUX[3] := N; AUX[5] := NORM;
BI1 := B[N] := BI / D; BI := B[N1] := B[N1] - SUPER[N1] × BI1;
for I := N - 2 step -1 until 1 do
begin BI2 := BI1; BI1 := BI;
BI := B[I] := B[I] - SUPER[I] × BI1 -
(if PIV[I] then SUB[I] × BI2 else 0)
end;
EXIT:
end DECSOLTRIPIV;
comment ================== 34330 ================= ;
procedure CHLDECBND(A, N, W, AUX); value N, W; integer N, W;
array A, AUX;
begin integer J, K, JMAX, KK, KJ, W1, START;
real R, EPS, MAX;
real procedure VECVEC(L, U, S, A, B); code 34010;
MAX := 0; KK := - W; W1 := W + 1;
for J := 1 step 1 until N do
begin KK := KK + W1; if A[KK] > MAX then MAX := A[KK] end;
JMAX := W; W1 := W + 1; KK := - W; EPS := AUX[2] × MAX;
for K := 1 step 1 until N do
begin if K + W > N then JMAX := JMAX - 1; KK := KK + W1;
START := KK - K + 1;
R := A[KK] - VECVEC(if K ≤ W1 then START else KK - W,
KK - 1, 0, A, A); if R ≤ EPS then
begin AUX[3] := K - 1; go to END end;
A[KK] := R := SQRT(R); KJ := KK;
for J := 1 step 1 until JMAX do
begin KJ := KJ + W;
A[KJ] := (A[KJ] - VECVEC(if K + J ≤ W1 then START
else KK - W + J, KK - 1, KJ - KK, A, A)) / R
end
end;
AUX[3] := N;
END:
end CHLDECBND;
comment ================== 34331 ================= ;
real procedure CHLDETERMBND(A, N, W); value N, W; integer N, W;
array A;
begin integer J, KK, W1; real P;
W1 := W + 1; KK := - W; P := 1;
for J := 1 step 1 until N do
begin KK := KK + W1; P := A[KK] × P end;
CHLDETERMBND := P × P
end CHLDETERMBND;
comment ================== 34332 ================= ;
procedure CHLSOLBND(A, N, W, B); value N, W; integer N, W;
array A, B;
begin integer I, K, IMAX, KK, W1;
real procedure VECVEC(L, U, S, A, B); code 34010;
real procedure SCAPRD1(LA, SA, LB, SB, N, A, B);
code 34017;
KK := - W; W1 := W + 1;
for K := 1 step 1 until N do
begin KK := KK + W1;
B[K] := (B[K] - VECVEC(if K ≤ W1 then 1 else K - W,
K - 1, KK - K, B, A)) / A[KK]
end;
IMAX := - 1;
for K := N step - 1 until 1 do
begin if IMAX < W then IMAX := IMAX + 1;
B[K] := (B[K] - SCAPRD1(KK + W, W, K + 1, 1, IMAX, A, B)) /
A[KK]; KK := KK - W1
end
end CHLSOLBND;
comment ================== 34333 ================= ;
procedure CHLDECSOLBND(A, N, W, AUX, B); value N, W;
integer N, W; array A, AUX, B;
begin procedure CHLDECBND(A, N, W, AUX); code 34330;
procedure CHLSOLBND(A, N, W, B); code 34332;
CHLDECBND(A, N, W, AUX);
if AUX[3] = N then CHLSOLBND(A, N, W, B)
end CHLDECSOLBND;
comment ================== 34420 ================= ;
procedure DECSYMTRI(DIAG, CO, N, AUX); value N; integer N;
array DIAG, CO, AUX;
begin integer I, N1;
real D, R, S, U, TOL, NORM, NORMR;
TOL := AUX[2]; D := DIAG[1]; R := CO[1];
NORM := NORMR := ABS(D) + ABS(R);
if ABS(D) ≤ NORMR × TOL then
begin AUX[3] := 0; AUX[5] := D; goto EXIT end;
U := CO[1] := R / D; N1 := N - 1;
for I := 2 step 1 until N1 do
begin S := R; R := CO[I]; D := DIAG[I];
NORMR := ABS(S) + ABS(D) + ABS(R);
D := DIAG[I] := D - U × S;
if ABS(D) ≤ NORMR × TOL then
begin AUX[3] := I - 1; AUX[5] := D; goto EXIT end;
U := CO[I] := R / D; if NORMR > NORM then NORM := NORMR
end;
D := DIAG[N]; NORMR := ABS(D) + ABS(R);
D := DIAG[N] := D - U × R;
if ABS(D) ≤ NORMR × TOL then
begin AUX[3] := N1; AUX[5] := D; goto EXIT end;
if NORMR > NORM then NORM := NORMR;
AUX[3] := N; AUX[5] := NORM;
EXIT:
end DECSYMTRI;
comment ================== 34421 ================= ;
procedure SOLSYMTRI(DIAG, CO, N, B); value N; integer N;
array DIAG, CO, B;
begin integer I;
real R, S;
R := B[1]; B[1] := R / DIAG[1];
for I := 2 step 1 until N do
begin R := B[I] - CO[I-1] × R; B[I] := R / DIAG[I] end;
S := B[N];
for I := N - 1 step -1 until 1 do
S := B[I] := B[I] - CO[I] × S
end SOLSYMTRI;
comment ================== 34422 ================= ;
procedure DECSOLSYMTRI(DIAG, CO, N, AUX, B); value N;
integer N; array DIAG, CO, AUX, B;
begin procedure DECSYMTRI(DIAG, CO, N, AUX); code 34420;
procedure SOLSYMTRI(DIAG, CO, N, B); code 34421;
DECSYMTRI(DIAG, CO, N, AUX); if AUX[3] = N then
SOLSYMTRI(DIAG, CO, N, B)
end DECSOLSYMTRI;
comment ================== 34220 ================= ;
procedure CONJ GRAD( MATVEC, X, R, L, N, GO ON, ITERATE, NORM2);
value L, N; procedure MATVEC; array X, R; Boolean GO ON;
integer L, N, ITERATE; real NORM2;
begin array P, AP[ L: N];
integer I;
real A, B, PRR, RRP;
real procedure VECVEC( A, B, C, D, E); code 34010;
procedure ELMVEC( A, B, C, D, E, F); code 34020;
for ITERATE := 0, ITERATE + 1 while GO ON do
begin if ITERATE = 0 then
begin MATVEC( X, P);
for I := L step 1 until N do
P[ I] := R[ I] := R[ I] - P[ I];
PRR := VECVEC( L, N, 0, R, R)
end else
begin B := RRP / PRR; PRR := RRP;
for I := L step 1 until N do
P[ I] := R[ I] + B × P[ I]
end;
MATVEC( P, AP);
A := PRR / VECVEC( L, N, 0, P, AP);
ELMVEC( L, N, 0, X, P, A);
ELMVEC( L, N, 0, R, AP, -A);
NORM2 := RRP := VECVEC( L, N, 0, R, R)
end
end CONJ GRAD;
comment ================== 34173 ================= ;
comment MCA 2405;
procedure EQILBR(A, N, EM, D, INT); value N; integer N;
array A, EM, D; integer array INT;
begin integer I, IM, I1, P, Q, J, T, COUNT, EXPONENT, NI;
real C, R, EPS, OMEGA, FACTOR;
procedure MOVE(K); value K; integer K;
begin real DI;
NI := Q - P; T := T + 1; if K ≠ I then
begin ICHCOL(1, N, K, I, A); ICHROW(1, N, K, I, A);
DI := D[I]; D[I] := D[K]; D[K] := DI
end
end MOVE;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
real procedure MATTAM(L, U, I, J, A, B); code 34015;
procedure ICHCOL(L, U, I, J, A); code 34031;
procedure ICHROW(L, U, I, J, A); code 34032;
FACTOR := 1 / (2 × LN(2)); comment MORE GENERALLY: LN(BASE);
EPS := EM[0]; OMEGA := 1 / EPS; T := P := 1; Q := NI := I := N;
COUNT := (N + 1) × N ÷ 2;
for J := 1 step 1 until N do
begin D[J] := 1; INT[J] := 0 end;
for I := if I < Q then I + 1 else P
while COUNT > 0 ∧ NI > 0 do
begin COUNT := COUNT - 1; IM := I - 1; I1 := I + 1;
C := SQRT(TAMMAT(P, IM, I, I, A, A) +
TAMMAT(I1, Q, I, I, A, A));
R := SQRT(MATTAM(P, IM, I, I, A, A) +
MATTAM(I1, Q, I, I, A, A));
if C × OMEGA ≤ R × EPS then
begin INT[T] := I; MOVE(P); P := P + 1 end
else if R × OMEGA ≤ C × EPS then
begin INT[T] := -I; MOVE(Q); Q := Q - 1 end
else
begin EXPONENT := LN(R / C) × FACTOR;
if ABS(EXPONENT) > 1 then
begin NI := Q - P; C := 2 ⭡ EXPONENT; R := 1 / C;
D[I] := D[I] × C;
for J := 1 step 1 until IM,
I1 step 1 until N do
begin A[J, I] := A[J, I] × C;
A[I, J] := A[I, J] × R
end
end else NI := NI - 1
end
end
end EQILBR;
comment ================== 34174 ================= ;
comment MCA 2406;
procedure BAKLBR(N, N1, N2, D, INT, VEC); value N, N1, N2;
integer N, N1, N2; array D, VEC; integer array INT;
begin integer I, J, K, P, Q; real DI;
procedure ICHROW(L, U, I, J, A); code 34032;
P := 1; Q := N;
for I := 1 step 1 until N do
begin DI := D[I]; if DI ≠ 1 then
for J := N1 step 1 until N2 do VEC[I, J] :=
VEC[I, J] × DI; K := INT[I];
if K > 0 then P := P + 1 else
if K < 0 then Q := Q - 1
end;
for I := P - 1 + N - Q step -1 until 1 do
begin K := INT[I]; if K > 0 then
begin P := P - 1; if K ≠ P then
ICHROW(N1, N2, K, P, VEC)
end else
begin Q := Q + 1; if -K ≠ Q then
ICHROW(N1, N2, -K, Q, VEC)
end
end
end BAKLBR;
comment ================== 34361 ================= ;
procedure EQILBRCOM(A1, A2, N, EM, D, INT); value N;
integer N; array A1, A2, EM, D; integer array INT;
begin integer I, P, Q, J, T, COUNT, EXPONENT, NI, IM, I1;
real C, R, EPS;
procedure ICHCOL(L, U, I, J, A); code 34031;
procedure ICHROW(L, U, I, J, A); code 34032;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
real procedure MATTAM(L, U, I, J, A, B); code 34015;
procedure MOVE(K); value K; integer K;
begin real DI;
NI := Q - P; T := T + 1; if K ≠ I then
begin ICHCOL(1, N, K, I, A1); ICHROW(1, N, K, I, A1);
ICHCOL(1, N, K, I, A2); ICHROW(1, N, K, I, A2);
DI := D[I]; D[I] := D[K]; D[K] := DI
end
end MOVE;
EPS := EM[0] ⭡ 4; T := P := 1; Q := NI := I := N;
COUNT := EM[6];
for J := 1 step 1 until N do
begin D[J] := 1; INT[J] := 0 end;
for I := if I < Q then I + 1 else P while COUNT > 0
∧ NI > 0 do
begin COUNT := COUNT - 1; IM := I - 1; I1 := I + 1;
C := TAMMAT(P, IM, I, I, A1, A1) + TAMMAT(I1, Q, I,
I, A1, A1) + TAMMAT(P, IM, I, I, A2, A2) +
TAMMAT(I1, Q, I, I, A2, A2);
R := MATTAM(P, IM, I, I, A1, A1) + MATTAM(I1, Q, I,
I, A1, A1) + MATTAM(P, IM, I, I, A2, A2) +
MATTAM(I1, Q, I, I, A2, A2); if C / EPS ≤ R then
begin INT[T] := I; MOVE(P); P := P + 1 end
else if R / EPS ≤ C then
begin INT[T] := - I; MOVE(Q); Q := Q - 1 end
else
begin EXPONENT := LN(R / C) × 0.36067;
if ABS(EXPONENT) > 1 then
begin NI := Q - P; C := 2 ⭡ EXPONENT;
D[I] := D[I] × C;
for J := 1 step 1 until IM, I1 step 1
until N do
begin A1[J, I] := A1[J, I] × C;
A1[I, J] := A1[I, J] / C;
A2[J, I] := A2[J, I] × C;
A2[I, J] := A2[I, J] / C
end
end
else NI := NI - 1
end
end;
EM[7] := EM[6] - COUNT
end EQILBRCOM;
comment ================== 34362 ================= ;
procedure BAKLBRCOM(N, N1, N2, D, INT, VR, VI);
value N, N1, N2; integer N, N1, N2; array D, VR, VI;
integer array INT;
begin
procedure BAKLBR(N, N1, N2, D, INT, VEC); code 34174;
BAKLBR(N, N1, N2, D, INT, VR);
BAKLBR(N, N1, N2, D, INT, VI)
end BAKLBRCOM;
comment ================== 34140 ================= ;
comment MCA 2300;
procedure TFMSYMTRI2(A, N, D, B, BB, EM); value N; integer N;
array A, B, BB, D, EM;
begin integer I, J, R, R1;
real W, X, A1, B0, BB0, D0, MACHTOL, NORM;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
real procedure MATMAT(L, U, I, J, A, B); code 34013;
procedure ELMVECCOL(L, U, I, A, B, X); code 34021;
real procedure TAMVEC(L, U, I, A, B); code 34012;
procedure ELMCOL(L, U, I, J, A, B, X); code 34023;
procedure ELMCOLVEC(L, U, I, A, B, X); code 34022;
NORM := 0;
for J := 1 step 1 until N do
begin W := 0;
for I := 1 step 1 until J do W := ABS(A[I, J]) + W;
for I := J + 1 step 1 until N do W := ABS(A[J, I]) +
W; if W > NORM then NORM := W
end;
MACHTOL := EM[0] × NORM; EM[1] := NORM; R := N;
for R1 := N - 1 step -1 until 1 do
begin D[R] := A[R, R]; X := TAMMAT(1, R - 2, R, R, A, A);
A1 := A[R1, R]; if SQRT(X) ≤ MACHTOL then
begin B0 := B[R1] := A1; BB[R1] := B0 × B0; A[R, R] := 1 end
else
begin BB0 := BB[R1] := A1 × A1 + X;
B0 := if A1 > 0 then -SQRT(BB0) else SQRT(BB0);
A1 := A[R1, R] := A1 - B0; W := A[R, R] := 1 / (A1 × B0);
for J := 1 step 1 until R1 do B[J] := (TAMMAT(1,
J, J, R, A, A) + MATMAT(J + 1, R1, J, R, A, A)) × W;
ELMVECCOL(1, R1, R, B, A, TAMVEC(1, R1, R, A, B) ×
W × .5); for J := 1 step 1 until R1 do
begin ELMCOL(1, J, J, R, A, A, B[J]);
ELMCOLVEC(1, J, J, A, B, A[J, R])
end; B[R1] := B0
end; R := R1
end;
D[1] := A[1, 1]; A[1, 1] := 1; B[N] := BB[N] := 0
end TFMSYMTRI2;
comment ================== 34141 ================= ;
comment MCA 2301;
procedure BAKSYMTRI2(A, N, N1, N2, VEC); value N, N1, N2;
integer N, N1, N2; array A, VEC;
begin integer I, J, K; real W;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
procedure ELMCOL(L, U, I, J, A, B, X); code 34023;
for J := 2 step 1 until N do
begin W := A[J, J]; if W < 0 then
for K := N1 step 1 until N2 do
ELMCOL(1, J - 1, K, J, VEC, A,
TAMMAT(1, J - 1, J, K, A, VEC) × W)
end
end BAKSYMTRI2;
comment ================== 34142 ================= ;
comment MCA 2302;
procedure TFMPREVEC(A, N); value N; integer N; array A;
begin integer I, J, J1, K; real AB;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
procedure ELMCOL(L, U, I, J, A, B, X); code 34023;
J1 := 1;
for J := 2 step 1 until N do
begin for I := 1 step 1 until J1 - 1 ,
J step 1 until N do A[I, J1] := 0;
A[J1, J1] := 1; AB := A[J, J];
if AB < 0 then
for K := 1 step 1 until J1 do
ELMCOL(1, J1, K, J, A, A,
TAMMAT(1, J1, J, K, A, A) × AB); J1 := J
end;
for I := N - 1 step -1 until 1 do
A[I, N] := 0; A[N, N] := 1
end TFMPREVEC;
comment ================== 34143 ================= ;
comment MCA 2305;
procedure TFMSYMTRI1(A, N, D, B, BB, EM); value N; integer N;
array A, B, BB, D, EM;
begin integer I, J, R, R1, P, Q, TI, TJ;
real S, W, X, A1, B0, BB0, D0, NORM, MACHTOL;
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
real procedure SEQVEC(L, U, IL, SHIFT, A, B); code 34016;
procedure ELMVEC(L, U, SHIFT, A, B, X); code 34020;
NORM := 0; TJ := 0;
for J := 1 step 1 until N do
begin W := 0;
for I := 1 step 1 until J do W := ABS(A[I + TJ]) + W;
TJ := TJ + J; TI := TJ + J;
for I := J + 1 step 1 until N do
begin W := ABS(A[TI]) + W; TI := TI + I end;
if W > NORM then NORM := W
end;
MACHTOL := EM[0] × NORM; EM[1] := NORM; Q := (N + 1) × N ÷ 2;
R := N; for R1 := N - 1 step -1 until 1 do
begin P := Q - R; D[R] := A[Q];
X := VECVEC(P + 1, Q - 2, 0, A, A);
A1 := A[Q - 1]; if SQRT(X) ≤ MACHTOL then
begin B0 := B[R1] := A1; BB[R1] := B0 × B0; A[Q] := 1 end
else
begin BB0 := BB[R1] := A1 × A1 + X;
B0 := if A1 > 0 then -SQRT(BB0) else SQRT(BB0);
A1 := A[Q - 1] := A1 - B0; W := A[Q] := 1 / (A1 × B0);
TJ := 0; for J := 1 step 1 until R1 do
begin TI := TJ + J; S := VECVEC(TJ + 1, TI, P - TJ,
A, A); TJ := TI + J;
B[J] := (SEQVEC(J + 1, R1, TJ, P, A, A) + S) × W;
TJ := TI
end;
ELMVEC(1, R1, P, B, A, VECVEC(1, R1, P, B, A) × W × .5);
TJ := 0; for J := 1 step 1 until R1 do
begin TI := TJ + J; ELMVEC(TJ + 1, TI, P - TJ, A, A,
B[J]); ELMVEC(TJ + 1, TI, -TJ, A, B, A[J + P]);
TJ := TI
end; B[R1] := B0
end;
Q := P; R := R1
end;
D[1] := A[1]; A[1] := 1; B[N] := BB[N] := 0
end TFMSYMTRI1;
comment ================== 34144 ================= ;
comment MCA 2306;
procedure BAKSYMTRI1(A, N, N1, N2, VEC); value N, N1, N2;
integer N, N1, N2; array A, VEC;
begin integer J, J1, K, TI, TJ;
real W; array AUXVEC[1:N];
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
procedure ELMVEC(L, U, SHIFT, A, B, X); code 34020;
for K := N1 step 1 until N2 do
begin for J := 1 step 1 until N do
AUXVEC[J] := VEC[J, K]; TJ := J1 := 1;
for J := 2 step 1 until N do
begin TI := TJ + J; W := A[TI];
if W < 0 then ELMVEC(1, J1, TJ, AUXVEC, A, VECVEC(1,
J1, TJ, AUXVEC, A) × W); J1 := J; TJ := TI
end;
for J := 1 step 1 until N do VEC[J, K] := AUXVEC[J]
end
end BAKSYMTRI1;
comment ================== 34170 ================= ;
comment MCA 2400;
procedure TFMREAHES(A, N, EM, INT); value N; integer N;
array A, EM; integer array INT;
begin integer I, J, J1, K, L;
real S, T, MACHTOL, MACHEPS, NORM;
array B[0:N - 1];
real procedure MATVEC(L, U, I, A, B); code 34011;
real procedure MATMAT(L, U, I, J, A, B); code 34013;
procedure ICHCOL(L, U, I, J, A); code 34031;
procedure ICHROW(L, U, I, J, A); code 34032;
MACHEPS := EM[0]; NORM := 0;
for I := 1 step 1 until N do
begin S := 0;
for J := 1 step 1 until N do S := S + ABS(A[I, J]);
if S > NORM then NORM := S
end;
EM[1] := NORM; MACHTOL := NORM × MACHEPS; INT[1] := 0;
for J := 2 step 1 until N do
begin J1 := J - 1; L := 0; S := MACHTOL;
for K := J + 1 step 1 until N do
begin T := ABS(A[K, J1]); if T > S then
begin L := K; S := T end
end;
if L ≠ 0 then
begin if ABS(A[J, J1]) < S then
begin ICHROW(1, N, J, L, A);
ICHCOL(1, N, J, L, A)
end
else L := J; T := A[J, J1];
for K := J + 1 step 1 until N do
A[K, J1] := A[K, J1] / T
end
else
for K := J + 1 step 1 until N do A[K, J1] := 0;
for I := 1 step 1 until N do
B[I - 1] := A[I, J] := A[I, J] +
(if L = 0 then 0 else MATMAT(J + 1, N, I, J1, A, A))-
MATVEC(1, if J1 < I - 2 then J1 else I - 2, I, A, B);
INT[J] := L
end
end TFMREAHES;
comment ================== 34171 ================= ;
comment MCA 2401;
procedure BAKREAHES1(A, N, INT, V); value N; integer N;
array A, V; integer array INT;
begin integer I, L;
real W; array X[1:N];
real procedure MATVEC(L, U, I, A, B); code 34011;
for I := 2 step 1 until N do X[I - 1] := V[I];
for I := N step -1 until 2 do
begin V[I] := V[I] + MATVEC(1, I - 2, I, A, X);
L := INT[I]; if L > I then
begin W := V[I]; V[I] := V[L]; V[L] := W end
end
end BAKREAHES1;
comment ================== 34172 ================= ;
comment MCA 2402;
procedure BAKREAHES2(A, N, N1, N2, INT, VEC); value N, N1, N2;
integer N, N1, N2; array A, VEC; integer array INT;
begin integer I, L, K; array U[1:N];
real procedure TAMVEC(L, U, I, A, B); code 34012;
procedure ICHROW(L, U, I, J, A); code 34032;
for I := N step -1 until 2 do
begin for K := I - 2 step -1 until 1 do
U[K + 1] := A[I, K];
for K := N1 step 1 until N2 do
VEC[I, K] := VEC[I, K] + TAMVEC(2 , I - 1, K, VEC, U);
L := INT[I]; if L > I then ICHROW(N1, N2, I, L, VEC)
end
end BAKREAHES2;
comment ================== 34363 ================= ;
procedure HSHHRMTRI(A, N, D, B, BB, EM, TR, TI); value N;
integer N; array A, D, B, BB, EM, TR, TI;
begin integer I, J, J1, JM1, R, RM1;
real NRM, W, TOL2, X, AR, AI, MOD, C, S, H, K, T, Q,
AJR, ARJ, BJ, BBJ;
real procedure MATVEC(L, U, I, A, B); code 34011;
real procedure TAMVEC(L, U, I, A, B); code 34012;
real procedure MATMAT(L, U, I, J, A, B); code 34013;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
real procedure MATTAM(L, U, I, J, A, B); code 34015;
procedure ELMVECCOL(L, U, I, A, B, X); code 34021;
procedure ELMCOLVEC(L, U, I, A, B, X); code 34022;
procedure ELMCOL(L, U, I, J, A, B, X); code 34023;
procedure ELMROW(L, U, I, J, A, B, X); code 34024;
procedure ELMVECROW(L, U, I, A, B, X); code 34026;
procedure ELMROWVEC(L, U, I, A, B, X); code 34027;
procedure ELMROWCOL(L, U, I, J, A, B, X); code 34028;
procedure ELMCOLROW(L, U, I, J, A, B, X); code 34029;
procedure CARPOL(AR, AI, R, C, S); code 34344;
NRM := 0;
for I := 1 step 1 until N do
begin W := ABS(A[I, I]);
for J := I - 1 step - 1 until 1, I + 1 step 1
until N do W := W + ABS(A[I, J]) + ABS(A[J, I]);
if W > NRM then NRM := W
end I;
TOL2 := (EM[0] × NRM) ⭡ 2; EM[1] := NRM; R := N;
for RM1 := N - 1 step - 1 until 1 do
begin X := TAMMAT(1, R - 2, R, R, A, A) + MATTAM(1, R -
2, R, R, A, A); AR := A[RM1, R]; AI := - A[R, RM1];
D[R] := A[R, R]; CARPOL(AR, AI, MOD, C, S);
if X < TOL2 then
begin A[R, R] := - 1; B[RM1] := MOD;
BB[RM1] := MOD × MOD
end
else
begin H := MOD × MOD + X; K := SQRT(H);
T := A[R, R] := H + MOD × K;
if AR = 0 ∧ AI = 0 then A[RM1, R] := K else
begin A[RM1, R] := AR + C × K;
A[R, RM1] := - AI - S × K; S := - S
end;
C := - C; J := 1; JM1 := 0;
for J1 := 2 step 1 until R do
begin B[J] := (TAMMAT(1, J, J, R, A, A) +
MATMAT(J1, RM1, J, R, A, A) + MATTAM(1,
JM1, J, R, A, A) - MATMAT(J1, RM1, R, J,
A, A)) / T;
BB[J] := (MATMAT(1, JM1, J, R, A, A) -
TAMMAT(J1, RM1, J, R, A, A) - MATMAT(1, J,
R, J, A, A) - MATTAM(J1, RM1, J, R, A, A))
/ T; JM1 := J; J := J1
end J1;
Q := (TAMVEC(1, RM1, R, A, B) - MATVEC(1, RM1,
R, A, BB)) / T / 2;
ELMVECCOL(1, RM1, R, B, A, - Q);
ELMVECROW(1, RM1, R, BB, A, Q); J := 1;
for J1 := 2 step 1 until R do
begin AJR := A[J, R]; ARJ := A[R, J]; BJ := B[J];
BBJ := BB[J];
ELMROWVEC(J, RM1, J, A, B, - AJR);
ELMROWVEC(J, RM1, J, A, BB, ARJ);
ELMROWCOL(J, RM1, J, R, A, A, - BJ);
ELMROW(J, RM1, J, R, A, A, BBJ);
ELMCOLVEC(J1, RM1, J, A, B, - ARJ);
ELMCOLVEC(J1, RM1, J, A, BB, - AJR);
ELMCOL(J1, RM1, J, R, A, A, BBJ);
ELMCOLROW(J1, RM1, J, R, A, A, BJ); J := J1;
end J1;
BB[RM1] := H; B[RM1] := K;
end;
TR[RM1] := C; TI[RM1] := S; R := RM1;
end RM1;
D[1] := A[1, 1];
end HSHHRMTRI;
comment ================== 34365 ================= ;
procedure BAKHRMTRI(A, N, N1, N2, VECR, VECI, TR, TI);
value N, N1, N2; integer N, N1, N2;
array A, VECR, VECI, TR, TI;
begin integer I, J, R, RM1;
real C, S, T, QR, QI;
real procedure MATMAT(L, U, I, J, A, B); code 34013;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
procedure ELMCOL(L, U, I, J, A, B, X); code 34023;
procedure ELMCOLROW(L, U, I, J, A, B, X); code 34029;
procedure COMMUL(AR, AI, BR, BI, RR, RI); code 34341;
procedure COMROWCST(L, U, I, AR, AI, XR, XI); code 34353;
for I := 1 step 1 until N do
for J := N1 step 1 until N2 do VECI[I, J] := 0; C := 1;
S := 0;
for J := N - 1 step - 1 until 1 do
begin COMMUL(C, S, TR[J], TI[J], C, S);
COMROWCST(N1, N2, J, VECR, VECI, C, S)
end J;
RM1 := 2;
for R := 3 step 1 until N do
begin T := A[R, R]; if T > 0 then
for J := N1 step 1 until N2 do
begin QR := (TAMMAT(1, RM1, R, J, A, VECR) -
MATMAT(1, RM1, R, J, A, VECI)) / T;
QI := (TAMMAT(1, RM1, R, J, A, VECI) +
MATMAT(1, RM1, R, J, A, VECR)) / T;
ELMCOL(1, RM1, J, R, VECR, A, - QR);
ELMCOLROW(1, RM1, J, R, VECR, A, - QI);
ELMCOLROW(1, RM1, J, R, VECI, A, QR);
ELMCOL(1, RM1, J, R, VECI, A, - QI)
end;
RM1 := R;
end R;
end BAKHRMTRI;
comment ================== 34364 ================= ;
procedure HSHHRMTRIVAL(A, N, D, BB, EM); value N; integer N;
array A, D, BB, EM;
begin integer I, J, J1, JM1, R, RM1;
real NRM, W, TOL2, X, AR, AI, H, T, Q, AJR, ARJ, DJ,
BBJ, MOD2;
real procedure MATVEC(L, U, I, A, B); code 34011;
real procedure TAMVEC(L, U, I, A, B); code 34012;
real procedure MATMAT(L, U, I, J, A, B); code 34013;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
real procedure MATTAM(L, U, I, J, A, B); code 34015;
procedure ELMVECCOL(L, U, I, A, B, X); code 34021;
procedure ELMCOLVEC(L, U, I, A, B, X); code 34022;
procedure ELMCOL(L, U, I, J, A, B, X); code 34023;
procedure ELMROW(L, U, I, J, A, B, X); code 34024;
procedure ELMVECROW(L, U, I, A, B, X); code 34026;
procedure ELMROWVEC(L, U, I, A, B, X); code 34027;
procedure ELMROWCOL(L, U, I, J, A, B, X); code 34028;
procedure ELMCOLROW(L, U, I, J, A, B, X); code 34029;
NRM := 0;
for I := 1 step 1 until N do
begin W := ABS(A[I, I]);
for J := I - 1 step - 1 until 1, I + 1 step 1
until N do W := W + ABS(A[I, J]) + ABS(A[J, I]);
if W > NRM then NRM := W
end I;
TOL2 := (EM[0] × NRM) ⭡ 2; EM[1] := NRM; R := N;
for RM1 := N - 1 step - 1 until 1 do
begin X := TAMMAT(1, R - 2, R, R, A, A) + MATTAM(1, R -
2, R, R, A, A); AR := A[RM1, R]; AI := - A[R, RM1];
D[R] := A[R, R];
if X < TOL2 then BB[RM1] := AR × AR + AI × AI else
begin MOD2 := AR × AR + AI × AI; if MOD2 = 0 then
begin A[RM1, R] := SQRT(X); T := X end
else
begin X := X + MOD2; H := SQRT(MOD2 × X);
T := X + H; H := 1 + X / H;
A[R, RM1] := - AI × H; A[RM1, R] := AR × H;
end;
J := 1; JM1 := 0;
for J1 := 2 step 1 until R do
begin D[J] := (TAMMAT(1, J, J, R, A, A) +
MATMAT(J1, RM1, J, R, A, A) + MATTAM(1,
JM1, J, R, A, A) - MATMAT(J1, RM1, R, J,
A, A)) / T;
BB[J] := (MATMAT(1, JM1, J, R, A, A) -
TAMMAT(J1, RM1, J, R, A, A) - MATMAT(1, J,
R, J, A, A) - MATTAM(J1, RM1, J, R, A, A))
/ T; JM1 := J; J := J1
end J1;
Q := (TAMVEC(1, RM1, R, A, D) - MATVEC(1, RM1,
R, A, BB)) / T / 2;
ELMVECCOL(1, RM1, R, D, A, - Q);
ELMVECROW(1, RM1, R, BB, A, Q); J := 1;
for J1 := 2 step 1 until R do
begin AJR := A[J, R]; ARJ := A[R, J]; DJ := D[J];
BBJ := BB[J];
ELMROWVEC(J, RM1, J, A, D, - AJR);
ELMROWVEC(J, RM1, J, A, BB, ARJ);
ELMROWCOL(J, RM1, J, R, A, A, - DJ);
ELMROW(J, RM1, J, R, A, A, BBJ);
ELMCOLVEC(J1, RM1, J, A, D, - ARJ);
ELMCOLVEC(J1, RM1, J, A, BB, - AJR);
ELMCOL(J1, RM1, J, R, A, A, BBJ);
ELMCOLROW(J1, RM1, J, R, A, A, DJ); J := J1;
end J1;
BB[RM1] := X;
end;
R := RM1;
end RM1;
D[1] := A[1, 1];
end HSHHRMTRIVAL;
comment ================== 34366 ================= ;
procedure HSHCOMHES(AR, AI, N, EM, B, TR, TI, DEL); value N;
integer N; array AR, AI, EM, B, TR, TI, DEL;
begin integer R, RM1, I, J, NM1;
real TOL, T, XR, XI;
real procedure MATMAT(L, U, I, J, A, B); code 34013;
procedure ELMROWCOL(L, U, I, J, A, B, X); code 34028;
procedure HSHCOMPRD(I, II, L, U, J, AR, AI, BR, BI, T); code 34356;
procedure COMCOLCST(L, U, J, AR, AI, XR, XI); code 34352;
procedure COMROWCST(L, U, I, AR, AI, XR, XI); code 34353;
procedure CARPOL(AR, AI, R, C, S); code 34344;
procedure COMMUL(AR, AI, BR, BI, RR, RI); code 34341;
Boolean procedure HSHCOMCOL(L, U, J, AR, AI, TOL, K, C, S, T);
code 34355;
NM1 := N - 1; TOL := (EM[0] × EM[1]) ⭡ 2; RM1 := 1;
for R := 2 step 1 until NM1 do
begin if HSHCOMCOL(R, N, RM1, AR, AI, TOL, B[RM1],
TR[R], TI[R], T) then
begin for I := 1 step 1 until N do
begin XR := (MATMAT(R, N, I, RM1, AI, AI) -
MATMAT(R, N, I, RM1, AR, AR)) / T;
XI := ( - MATMAT(R, N, I, RM1, AR, AI) -
MATMAT(R, N, I, RM1, AI, AR)) / T;
ELMROWCOL(R, N, I, RM1, AR, AR, XR);
ELMROWCOL(R, N, I, RM1, AR, AI, XI);
ELMROWCOL(R, N, I, RM1, AI, AR, XI);
ELMROWCOL(R, N, I, RM1, AI, AI, - XR)
end;
HSHCOMPRD(R, N, R, N, RM1, AR, AI, AR, AI, T);
end;
DEL[RM1] := T; RM1 := R
end FORR;
if N > 1 then CARPOL(AR[N, NM1], AI[N, NM1], B[NM1],
TR[N], TI[N]); RM1 := 1; TR[1] := 1; TI[1] := 0;
for R := 2 step 1 until N do
begin COMMUL(TR[RM1], TI[RM1], TR[R], TI[R], TR[R],
TI[R]); COMCOLCST(1, RM1, R, AR, AI, TR[R], TI[R]);
COMROWCST(R + 1, N, R, AR, AI, TR[R], - TI[R]);
RM1 := R
end;
end HSHCOMHES;
comment ================== 34367 ================= ;
procedure BAKCOMHES(AR, AI, TR, TI, DEL, VR, VI, N, N1, N2);
value N, N1, N2; integer N, N1, N2;
array AR, AI, TR, TI, DEL, VR, VI;
begin integer I, R, RM1;
real H;
procedure HSHCOMPRD(I, II, L, U, J, AR, AI, BR, BI, T); code 34356;
procedure COMROWCST(L, U, I, AR, AI, XR, XI); code 34353;
for I := 2 step 1 until N do COMROWCST(N1, N2, I, VR,
VI, TR[I], TI[I]); R := N - 1;
for RM1 := N - 2 step - 1 until 1 do
begin H := DEL[RM1];
if H > 0 then HSHCOMPRD(R, N, N1, N2, RM1, VR, VI,
AR, AI, H); R := RM1
end
end BAKCOMHES;
comment ================== 34260 ================= ;
procedure HSHREABID(A, M, N, D, B, EM);
value M, N; integer M, N; array A, D, B, EM;
begin integer I, J, I1;
real NORM, MACHTOL, W, S, F, G, H;
real procedure TAMMAT(L, U, I, J, A, B);
value L, U, I, J; integer L, U, I, J; array A, B;
code 34014;
real procedure MATTAM(L, U, I, J, A, B);
value L, U, I, J; array A, B;
code 34015;
procedure ELMCOL(L, U, I, J, A, B, X);
value L, U, I, J, X; integer L, U, I, J; real X;
array A, B;
code 34023;
procedure ELMROW(L, U, I, J, A, B, X);
value L, U, I, J, X; integer L, U, I, J; real X;
array A, B;
code 34024;
NORM := 0;
for I := 1 step 1 until M do
begin W := 0;
for J := 1 step 1 until N do W := ABS(A[I, J]) + W;
if W > NORM then NORM := W
end;
MACHTOL := EM[0] × NORM; EM[1] := NORM;
for I := 1 step 1 until N do
begin I1 := I + 1; S := TAMMAT(I1, M, I, I, A, A);
if S < MACHTOL then D[I] := A[I, I] else
begin F := A[I, I]; S := F × F + S;
D[I] := G := if F < 0 then SQRT(S) else - SQRT(S);
H := F × G - S; A[I, I] := F - G;
for J := I1 step 1 until N do
ELMCOL(I, M, J, I, A, A, TAMMAT(I, M, I, J, A, A) / H)
end;
if I < N then
begin S := MATTAM(I1 + 1, N, I, I, A, A);
if S < MACHTOL then B[I] := A[I, I1] else
begin F := A[I, I1]; S := F × F + S;
B[I] := G := if F < 0 then SQRT(S) else - SQRT(S);
H := F × G - S; A[I, I1] := F - G;
for J := I1 step 1 until M do
ELMROW(I1, N, J, I, A, A, MATTAM(I1, N, I, J, A, A) /
H)
end
end
end
end HSHREABID;
comment ================== 34261 ================= ;
procedure PSTTFMMAT(A, N, V, B);
value N; integer N; array A, V, B;
begin integer I, I1, J;
real H;
real procedure MATMAT(L, U, I, J, A, B);
value L, U, I, J; integer L, U, I, J; array A, B;
code 34013;
procedure ELMCOL(L, U, I, J, A, B, X);
value L, U, I, J, X; integer L, U, I, J; real X;
array A, B;
code 34023;
I1 := N; V[N, N] := 1;
for I := N - 1 step - 1 until 1 do
begin H := B[I] × A[I, I1]; if H < 0 then
begin for J := I1 step 1 until N do V[J, I] := A[I, J] /
H;
for J := I1 step 1 until N do
ELMCOL(I1, N, J, I, V, V, MATMAT(I1, N, I, J, A, V))
end;
for J := I1 step 1 until N do V[I, J] := V[J, I] := 0;
V[I, I] := 1; I1 := I
end
end PSTTFMMAT;
comment ================== 34262 ================= ;
procedure PRETFMMAT(A, M, N, D);
value M, N; integer M, N; array A, D;
begin integer I, I1, J;
real G, H;
real procedure TAMMAT(L, U, I, J, A, B);
value L, U, I, J; integer L, U, I, J; array A, B;
code 34014;
procedure ELMCOL(L, U, I, J, A, B, X);
value L, U, I, J, X; integer L, U, I, J; real X;
array A, B;
code 34023;
for I := N step - 1 until 1 do
begin I1 := I + 1; G := D[I]; H := G × A[I, I];
for J := I1 step 1 until N do A[I, J] := 0;
if H < 0 then
begin for J := I1 step 1 until N do
ELMCOL(I, M, J, I, A, A, TAMMAT(I1, M, I, J, A, A) / H);
for J := I step 1 until M do A[J, I] := A[J, I] / G
end
else
for J := I step 1 until M do A[J, I] := 0;
A[I, I] := A[I, I] + 1
end
end PRETFMMAT;
comment ================== 34151 ================= ;
comment MCA 2311;
procedure VALSYMTRI(D, BB, N, N1, N2, VAL, EM);
value N, N1, N2;
integer N, N1, N2; array D, BB, VAL, EM;
begin integer K, COUNT;
real MAX, X, Y, MACHEPS, NORM, RE, MACHTOL, UB, LB, LAMBDA;
real procedure STURM;
begin integer P, I; real F;
COUNT := COUNT + 1;
P := K; F := D[1] - X;
for I := 2 step 1 until N do
begin if F ≤ 0 then
begin P := P + 1;
if P > N then goto OUT
end
else if P < I - 1 then
begin LB := X; goto OUT end;
if ABS(F) < MACHTOL then
F := if F ≤ 0 then - MACHTOL else MACHTOL;
F := D[I] - X - BB[I - 1] / F
end;
if P = N ∨ F ≤ 0 then
begin if X < UB then UB := X end else LB := X;
OUT: STURM := if P = N then F else (N - P) × MAX
end STURM;
Boolean procedure ZEROIN(X, Y, FX, TOLX); code 34150;
MACHEPS := EM[0]; NORM := EM[1]; RE := EM[2];
MACHTOL := NORM × MACHEPS; MAX := NORM / MACHEPS; COUNT := 0;
UB := 1.1 × NORM; LB := - UB; LAMBDA := UB;
for K := N1 step 1 until N2 do
begin X := LB; Y := UB; LB := -1.1 × NORM;
ZEROIN(X, Y, STURM, ABS(X) × RE + MACHTOL);
VAL[K] := LAMBDA := if X > LAMBDA then LAMBDA else X;
if UB > X then UB := if X > Y then X else Y
end;
EM[3] := COUNT
end VALSYMTRI;
comment ================== 34152 ================= ;
comment MCA 2312;
procedure VECSYMTRI(D, B, N, N1, N2, VAL, VEC, EM);
value N, N1, N2;
integer N, N1, N2; array D, B, VAL, VEC, EM;
begin integer I, J, K, COUNT, MAXCOUNT, COUNTLIM, ORTH, IND;
real BI, BI1, U, W, Y, MI1, LAMBDA, OLDLAMBDA, ORTHEPS,
VALSPREAD, SPR, RES, MAXRES, OLDRES, NORM, NEWNORM, OLDNORM,
MACHTOL, VECTOL;
array M, P, Q, R, X[1:N];
Boolean array INT[1:N];
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
procedure ELMVECCOL(L, U, I, A, B, X); code 34021;
real procedure TAMVEC(L, U, I, A, B); code 34012;
NORM := EM[1]; MACHTOL := EM[0] × NORM; VALSPREAD := EM[4] × NORM;
VECTOL := EM[6] × NORM; COUNTLIM := EM[8]; ORTHEPS := SQRT(EM[0]);
MAXCOUNT := IND := 0; MAXRES := 0;
if N1 > 1 then
begin ORTH := EM[5]; OLDLAMBDA := VAL[N1 - ORTH];
for K := N1 - ORTH + 1 step 1 until N1 - 1 do
begin LAMBDA := VAL[K]; SPR := OLDLAMBDA - LAMBDA;
if SPR < MACHTOL then LAMBDA := OLDLAMBDA - MACHTOL;
OLDLAMBDA := LAMBDA
end
end else ORTH := 1;
for K := N1 step 1 until N2 do
begin LAMBDA := VAL[K]; if K > 1 then
begin SPR := OLDLAMBDA - LAMBDA;
if SPR < VALSPREAD then
begin if SPR < MACHTOL then
LAMBDA := OLDLAMBDA - MACHTOL;
ORTH := ORTH + 1
end else ORTH := 1
end;
COUNT := 0; U := D[1] - LAMBDA; BI := W := B[1];
if ABS(BI) < MACHTOL then BI := MACHTOL;
for I := 1 step 1 until N - 1 do
begin BI1 := B[I + 1];
if ABS(BI1) < MACHTOL then BI1 := MACHTOL;
if ABS(BI) ≥ ABS(U) then
begin MI1 := M[I + 1] := U / BI; P[I] := BI;
Y := Q[I] := D[I + 1] - LAMBDA; R[I] := BI1;
U := W - MI1 × Y; W := - MI1 × BI1; INT[I] := true
end
else
begin MI1 := M[I + 1] := BI / U; P[I] := U; Q[I] := W;
R[I] := 0; U := D[I + 1] - LAMBDA - MI1 × W; W := BI1;
INT[I] := false
end;
X[I] := 1; BI := BI1
end TRANSFORM;
P[N] := if ABS(U) < MACHTOL then MACHTOL else U;
Q[N] := R[N] := 0; X[N] := 1; goto ENTRY;
ITERATE: W := X[1];
for I := 2 step 1 until N do
begin if INT[I - 1] then
begin U := W; W := X[I - 1] := X[I] end
else U := X[I]; W := X[I] := U - M[I] × W
end ALTERNATE;
ENTRY: U := W := 0;
for I := N step -1 until 1 do
begin Y := U; U := X[I] := (X[I] - Q[I] × U - R[I] × W) /
P[I]; W := Y
end NEXT ITERATION;
NEWNORM := SQRT(VECVEC(1, N, 0, X, X)); if ORTH > 1 then
begin OLDNORM := NEWNORM;
for J := K - ORTH + 1 step 1 until K - 1 do
ELMVECCOL(1, N, J, X, VEC, -TAMVEC(1, N, J, VEC, X));
NEWNORM := SQRT(VECVEC(1, N, 0, X, X));
if NEWNORM < ORTHEPS × OLDNORM then
begin IND := IND + 1; COUNT := 1;
for I := 1 step 1 until IND - 1,
IND + 1 step 1 until N do X[I] := 0;
X[IND] := 1; if IND = N then IND := 0;
goto ITERATE
end NEW START
end ORTHOGONALISATION;
RES := 1 / NEWNORM; if RES > VECTOL ∨ COUNT = 0 then
begin COUNT := COUNT + 1; if COUNT ≤ COUNTLIM then
begin for I := 1 step 1 until N do
X[I] := X[I] × RES; goto ITERATE
end
end;
for I := 1 step 1 until N do VEC[I, K] := X[I] × RES;
if COUNT > MAXCOUNT then MAXCOUNT := COUNT;
if RES > MAXRES then MAXRES := RES; OLDLAMBDA := LAMBDA
end;
EM[5] := ORTH; EM[7] := MAXRES; EM[9] := MAXCOUNT
end VECSYMTRI;
comment ================== 34161 ================= ;
comment MCA 2321;
integer procedure QRISYMTRI(A, N, D, B, BB, EM); value N;
integer N; array A, D, B, BB, EM;
begin integer I, J, J1, K, M, M1, COUNT, MAX;
real BBMAX, R, S, SIN, T, C, COS, OLDCOS, G, P, W, TOL, TOL2,
LAMBDA, DK1, A0, A1;
procedure ROTCOL(L, U, I, J, A, C, S); code 34040;
TOL := EM[2] × EM[1]; TOL2 := TOL × TOL; COUNT := 0; BBMAX := 0;
MAX := EM[4]; M := N;
IN: K := M; M1 := M - 1;
NEXT: K := K - 1; if K > 0 then
begin if BB[K] ≥ TOL2 then goto NEXT;
if BB[K] > BBMAX then BBMAX := BB[K]
end;
if K = M1 then M := M1 else
begin
T := D[M] - D[M1]; R := BB[M1];
if ABS(T) < TOL then S := SQRT(R) else
begin W := 2 / T; S := W × R / (SQRT(W × W × R + 1) + 1)
end; if K = M - 2 then
begin D[M] := D[M] + S; D[M1] := D[M1] - S;
T := - S / B[M1]; R := SQRT(T × T + 1); COS := 1 / R;
SIN := T / R; ROTCOL(1, N, M1, M, A, COS, SIN); M := M - 2
end
else
begin COUNT := COUNT + 1;
if COUNT > MAX then goto END;
LAMBDA := D[M] + S; if ABS(T) < TOL then
begin W := D[M1] - S;
if ABS(W) < ABS(LAMBDA) then LAMBDA := W
end;
K := K + 1; T := D[K] - LAMBDA; COS := 1; W := B[K];
P := SQRT(T × T + W × W); J1 := K;
for J := K + 1 step 1 until M do
begin OLDCOS := COS; COS := T / P; SIN := W / P;
DK1 := D[J] - LAMBDA; T := OLDCOS × T;
D[J1] := (T + DK1) × SIN × SIN + LAMBDA + T;
T := COS × DK1 - SIN × W × OLDCOS; W := B[J];
P := SQRT(T × T + W × W); G := B[J1] := SIN × P;
BB[J1] := G × G; ROTCOL(1, N, J1, J, A, COS, SIN);
J1 := J
end;
D[M] := COS × T + LAMBDA; if T < 0 then B[M1] := - G
end QRSTEP
end;
if M > 0 then goto IN;
END: EM[3] := SQRT(BBMAX); EM[5] := COUNT; QRISYMTRI := M
end QRISYMTRI;
comment ================== 34153 ================= ;
comment MCA 2313;
procedure EIGVALSYM2(A, N, NUMVAL, VAL, EM); value N, NUMVAL;
integer N, NUMVAL; array A, VAL, EM;
begin array B, BB, D[1:N];
procedure TFMSYMTRI2(A, N, D, B, BB, EM); code 34140;
procedure VALSYMTRI(D, BB, N, N1, N2, VAL, EM); code 34151;
TFMSYMTRI2(A, N, D, B, BB, EM);
VALSYMTRI(D, BB, N, 1, NUMVAL, VAL, EM)
end EIGVALSYM2;
comment ================== 34154 ================= ;
comment MCA 2314;
procedure EIGSYM2(A, N, NUMVAL, VAL, VEC, EM); value N, NUMVAL;
integer N, NUMVAL; array A, VAL, VEC, EM;
begin array B, BB, D[1:N];
procedure TFMSYMTRI2(A, N, D, B, BB, EM); code 34140;
procedure VALSYMTRI(D, BB, N, N1, N2, VAL, EM); code 34151;
procedure VECSYMTRI(D, B, N, N1, N2, VAL, VEC, EM);
code 34152;
procedure BAKSYMTRI2(A, N, N1, N2, VEC); code 34141;
TFMSYMTRI2(A, N, D, B, BB, EM);
VALSYMTRI(D, BB, N, 1, NUMVAL, VAL, EM);
VECSYMTRI(D, B, N, 1, NUMVAL, VAL, VEC, EM);
BAKSYMTRI2(A, N, 1, NUMVAL, VEC)
end EIGSYM2;
comment ================== 34155 ================= ;
comment MCA 2318;
procedure EIGVALSYM1(A, N, NUMVAL, VAL, EM); value N, NUMVAL;
integer N, NUMVAL; array A, VAL, EM;
begin array B, BB, D[1:N];
procedure TFMSYMTRI1(A, N, D, B, BB, EM); code 34143;
procedure VALSYMTRI(D, BB, N, N1, N2, VAL, EM); code 34151;
TFMSYMTRI1(A, N, D, B, BB, EM);
VALSYMTRI(D, BB, N, 1, NUMVAL, VAL, EM)
end EIGVALSYM1;
comment ================== 34156 ================= ;
comment MCA 2319;
procedure EIGSYM1(A, N, NUMVAL, VAL, VEC, EM); value N, NUMVAL;
integer N, NUMVAL; array A, VAL, VEC, EM;
begin array B, BB, D[1:N];
procedure TFMSYMTRI1(A, N, D, B, BB, EM); code 34143;
procedure VALSYMTRI(D, BB, N, N1, N2, VAL, EM); code 34151;
procedure VECSYMTRI(D, B, N, N1, N2, VAL, VEC, EM);
code 34152;
procedure BAKSYMTRI1(A, N, N1, N2, VEC); code 34144;
TFMSYMTRI1(A, N, D, B, BB, EM);
VALSYMTRI(D, BB, N, 1, NUMVAL, VAL, EM);
VECSYMTRI(D, B, N, 1, NUMVAL, VAL, VEC, EM);
BAKSYMTRI1(A, N, 1, NUMVAL, VEC)
end EIGSYM1;
comment ================== 34162 ================= ;
comment MCA 2322;
integer procedure QRIVALSYM2(A, N, VAL, EM); value N;
integer N; array A, VAL, EM;
begin array B, BB[1:N];
procedure TFMSYMTRI2(A, N, D, B, BB, EM); code 34140;
integer procedure QRIVALSYMTRI(D, BB, N, EM);
code 34160;
TFMSYMTRI2(A, N, VAL, B, BB, EM);
QRIVALSYM2 := QRIVALSYMTRI(VAL, BB, N, EM)
end QRIVALSYM2;
comment ================== 34163 ================= ;
comment MCA 2323;
integer procedure QRISYM(A, N, VAL, EM); value N;
integer N; array A, VAL, EM;
begin array B, BB[1:N];
procedure TFMSYMTRI2(A, N, D, B, BB, EM); code 34140;
procedure TFMPREVEC(A, N); code 34142;
integer procedure QRISYMTRI(A, N, D, B, BB, EM);
code 34161;
TFMSYMTRI2(A, N, VAL, B, BB, EM); TFMPREVEC(A, N);
QRISYM := QRISYMTRI(A, N, VAL, B, BB, EM)
end QRISYM;
comment ================== 34164 ================= ;
comment MCA 2327;
integer procedure QRIVALSYM1(A, N, VAL, EM); value N;
integer N; array A, VAL, EM;
begin array B, BB[1 : N];
procedure TFMSYMTRI1(A, N, D, B, BB, EM); code 34143;
integer procedure QRIVALSYMTRI(D, BB, N, EM);
code 34160;
TFMSYMTRI1(A, N, VAL, B, BB, EM);
QRIVALSYM1 := QRIVALSYMTRI(VAL, BB, N, EM)
end QRIVALSYM1;
comment ================== 34180 ================= ;
comment MCA 2410;
integer procedure REAVALQRI(A, N, EM, VAL); value N;
integer N; array A, EM, VAL;
begin integer N1, I, I1, J, Q, MAX, COUNT;
real DET, W, SHIFT, KAPPA, NU, MU, R, TOL, DELTA, MACHTOL, S;
procedure ROTCOL(L, U, I, J, A, C, S); code 34040;
procedure ROTROW(L, U, I, J, A, C, S); code 34041;
MACHTOL := EM[0] × EM[1]; TOL := EM[1] × EM[2]; MAX := EM[4];
COUNT := 0; R := 0;
IN: N1 := N - 1;
for I := N, I - 1 while (if I ≥ 1 then
ABS(A[I + 1, I]) > TOL else false) do Q := I;
if Q > 1 then
begin if ABS(A[Q, Q - 1]) > R then
R := ABS(A[Q, Q - 1])
end;
if Q = N then
begin VAL[N] := A[N, N]; N := N1 end
else
begin DELTA := A[N, N] - A[N1, N1]; DET := A[N, N1] × A[N1, N];
if ABS(DELTA) < MACHTOL then S := SQRT(DET) else
begin W := 2 / DELTA; S := W × W × DET + 1;
S := if S ≤ 0 then -DELTA × .5 else
W × DET / (SQRT(S) + 1)
end;
if Q = N1 then
begin VAL[N] := A[N, N] + S;
VAL[N1] := A[N1, N1] - S; N := N - 2
end
else
begin COUNT := COUNT + 1;
if COUNT > MAX then goto OUT;
SHIFT := A[N, N] + S; if ABS(DELTA) < TOL then
begin W := A[N1, N1] - S;
if ABS(W) < ABS(SHIFT) then SHIFT := W
end;
A[Q, Q] := A[Q, Q] - SHIFT;
for I := Q step 1 until N - 1 do
begin I1 := I + 1; A[I1, I1] := A[I1, I1] - SHIFT;
KAPPA := SQRT(A[I, I] ⭡ 2 + A[I1, I] ⭡ 2);
if I > Q then
begin A[I, I - 1] := KAPPA × NU;
W := KAPPA × MU
end
else W := KAPPA; MU := A[I, I] / KAPPA;
NU := A[I1, I] / KAPPA; A[I, I] := W;
ROTROW(I1, N, I, I1, A, MU, NU);
ROTCOL(Q, I, I, I1, A, MU, NU);
A[I, I] := A[I, I] + SHIFT
end;
A[N, N - 1] := A[N, N] × NU; A[N, N] := A[N, N] × MU + SHIFT
end
end;
if N > 0 then goto IN;
OUT: EM[3] := R; EM[5] := COUNT; REAVALQRI := N
end REAVALQRI;
comment ================== 34181 ================= ;
comment MCA 2411;
procedure REAVECHES(A, N, LAMBDA, EM, V); value N, LAMBDA;
integer N; real LAMBDA; array A, EM, V;
begin integer I, I1, J, COUNT, MAX;
real M, R, NORM, MACHTOL, TOL;
Boolean array P[1:N];
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
real procedure MATVEC(L, U, I, A, B); code 34011;
NORM := EM[1]; MACHTOL := EM[0] × NORM; TOL := EM[6] × NORM;
MAX := EM[8]; A[1, 1] := A[1, 1] - LAMBDA;
GAUSS: for I := 1 step 1 until N - 1 do
begin I1 := I + 1; R := A[I, I]; M := A[I1, I];
if ABS(M) < MACHTOL then M := MACHTOL;
P[I] := ABS(M) ≤ ABS(R);
if P[I] then
begin A[I1, I] := M := M / R;
for J := I1 step 1 until N do
A[I1, J] := (if J > I1 then A[I1, J]
else A[I1, J] - LAMBDA) - M × A[I, J]
end
else
begin A[I, I] := M; A[I1, I] := M := R / M;
for J := I1 step 1 until N do
begin R := (if J > I1 then A[I1, J] else
A[I1, J] - LAMBDA);
A[I1, J] := A[I, J] - M × R; A[I, J] := R
end
end
end GAUSS;
if ABS(A[N, N]) < MACHTOL then A[N, N] := MACHTOL;
for J := 1 step 1 until N do V[J] := 1; COUNT := 0;
FORWARD: COUNT := COUNT + 1; if COUNT > MAX then goto OUT;
for I := 1 step 1 until N - 1 do
begin I1 := I + 1;
if P[I] then V[I1] := V[I1] - A[I1, I] × V[I] else
begin R := V[I1]; V[I1] := V[I] - A[I1, I] × R;
V[I] := R
end
end FORWARD;
BACKWARD: for I := N step -1 until 1 do
V[I] := (V[I] - MATVEC(I + 1, N, I, A, V)) / A[I, I];
R := 1 / SQRT(VECVEC(1, N, 0, V, V));
for J := 1 step 1 until N do V[J] := V[J] × R;
if R > TOL then goto FORWARD;
OUT: EM[7] := R; EM[9] := COUNT
end REAVECHES;
comment ================== 34186 ================= ;
comment MCA 2416;
integer procedure REAQRI(A, N, EM, VAL, VEC); value N;
integer N; array A, EM, VAL, VEC;
begin integer M1, I, I1, M, J, Q, MAX, COUNT;
real W, SHIFT, KAPPA, NU, MU, R, TOL, S, MACHTOL,
ELMAX, T, DELTA, DET;
array TF[1:N];
real procedure MATVEC(L, U, I, A, B); code 34011;
procedure ROTCOL(L, U, I, J, A, C, S); code 34040;
procedure ROTROW(L, U, I, J, A, C, S); code 34041;
MACHTOL := EM[0] × EM[1]; TOL := EM[1] × EM[2]; MAX := EM[4];
COUNT := 0; ELMAX := 0; M := N;
for I := 1 step 1 until N do
begin VEC[I, I] := 1;
for J := I + 1 step 1 until N do
VEC[I, J] := VEC[J, I] := 0
end;
IN: M1 := M - 1;
for I := M, I - 1 while (if I ≥ 1 then
ABS(A[I + 1, I]) > TOL else false) do Q := I;
if Q > 1 then
begin if ABS(A[Q, Q - 1]) > ELMAX then
ELMAX := ABS(A[Q, Q - 1])
end;
if Q = M then
begin VAL[M] := A[M, M]; M := M1 end
else
begin DELTA := A[M, M] - A[M1, M1]; DET := A[M, M1] × A[M1, M];
if ABS(DELTA) < MACHTOL then S := SQRT(DET) else
begin W := 2 / DELTA; S := W × W × DET + 1;
S := if S ≤ 0 then -DELTA × .5 else
W × DET / (SQRT(S) + 1)
end;
if Q = M1 then
begin A[M, M] := VAL[M] := A[M, M] + S;
A[Q, Q] := VAL[Q] := A[Q, Q] - S;
T := if ABS(S) < MACHTOL then
(S + DELTA) / A[M, Q] else A[Q, M] / S;
R := SQRT(T × T + 1); NU := 1 / R;
MU := -T × NU; A[Q, M] := A[Q, M] - A[M, Q];
ROTROW(Q + 2, N, Q, M, A, MU, NU);
ROTCOL(1, Q - 1, Q, M, A, MU, NU);
ROTCOL(1, N, Q, M, VEC, MU, NU); M := M - 2
end
else
begin COUNT := COUNT + 1;
if COUNT > MAX then goto END;
SHIFT := A[M, M] + S; if ABS(DELTA) < TOL then
begin W := A[M1, M1] - S;
if ABS(W) < ABS(SHIFT) then SHIFT := W
end;
A[Q, Q] := A[Q, Q] - SHIFT;
for I := Q step 1 until M1 do
begin I1 := I + 1; A[I1, I1] := A[I1, I1] - SHIFT;
KAPPA := SQRT(A[I, I] ⭡ 2 + A[I1, I] ⭡ 2);
if I > Q then
begin A[I, I - 1] := KAPPA × NU;
W := KAPPA × MU
end
else W := KAPPA; MU := A[I, I] / KAPPA;
NU := A[I1, I] / KAPPA; A[I, I] := W;
ROTROW(I1, N, I, I1, A, MU, NU);
ROTCOL(1, I, I, I1, A, MU, NU);
A[I, I] := A[I, I] + SHIFT;
ROTCOL(1, N, I, I1, VEC, MU, NU)
end;
A[M, M1] := A[M, M] × NU; A[M, M] := A[M, M] × MU + SHIFT
end
end;
if M > 0 then goto IN;
for J := N step -1 until 2 do
begin TF[J] := 1; T := A[J, J];
for I := J - 1 step -1 until 1 do
begin DELTA := T - A[I, I];
TF[I] := MATVEC(I + 1, J, I, A, TF) /
(if ABS(DELTA) < MACHTOL then MACHTOL else DELTA)
end;
for I := 1 step 1 until N do
VEC[I, J] := MATVEC(1, J, I, VEC, TF)
end;
END: EM[3] := ELMAX; EM[5] := COUNT; REAQRI := M
end REAQRI;
comment ================== 34190 ================= ;
comment MCA 2420;
integer procedure COMVALQRI(A, N, EM, RE, IM); value N;
integer N; array A, EM, RE, IM;
begin integer I, J, P, Q, MAX, COUNT, N1, P1, P2, IMIN1,
I1, I2, I3;
real DISC, SIGMA, RHO, G1, G2, G3, PSI1, PSI2, AA, E, K,
S, NORM, MACHTOL2, TOL, W;
Boolean B;
NORM := EM[1]; MACHTOL2 := (EM[0] × NORM) ⭡ 2;
TOL := EM[2] × NORM; MAX := EM[4]; COUNT := 0; W := 0;
IN: for I := N, I - 1 while
(if I ≥ 1 then ABS(A[I + 1, I]) > TOL else false)
do Q := I; if Q > 1 then
begin if ABS(A[Q, Q - 1]) > W then W := ABS(A[Q, Q - 1])
end;
if Q ≥ N - 1 then
begin N1 := N - 1; if Q = N then
begin RE[N] := A[N, N]; IM[N] := 0; N := N1 end
else
begin SIGMA := A[N, N] - A[N1, N1];
RHO := -A[N, N1] × A[N1, N];
DISC := SIGMA ⭡ 2 - 4 × RHO; if DISC > 0 then
begin DISC := SQRT(DISC);
S := -2 × RHO / (SIGMA + (if SIGMA ≥ 0
then DISC else -DISC));
RE[N] := A[N, N] + S;
RE[N1] := A[N1, N1] - S; IM[N] := IM[N1] := 0
end
else
begin RE[N] := RE[N1] := (A[N1, N1] + A[N, N]) / 2;
IM[N1] := SQRT( -DISC) / 2; IM[N] := -IM[N1]
end;
N := N - 2
end
end
else
begin COUNT := COUNT + 1; if COUNT > MAX then
goto OUT; N1 := N - 1;
SIGMA := A[N, N] + A[N1, N1] + SQRT(ABS(A[N1, N - 2] × A[N, N1])
× EM[0]); RHO := A[N, N] × A[N1, N1] - A[N, N1] × A[N1, N];
for I := N - 1, I - 1 while
(if I - 1 ≥ Q then ABS(A[I, I - 1] ×
A[I1, I] × (ABS(A[I, I] + A[I1, I1] - SIGMA) +
ABS(A[I + 2, I1]))) > ABS(A[I, I] × ((A[I, I] - SIGMA) +
A[I, I1] × A[I1, I] + RHO)) × TOL
else false) do P1 := I1 := I; P := P1 - 1;
P2 := P + 2;
for I := P step 1 until N - 1 do
begin IMIN1 := I - 1; I1 := I + 1; I2 := I + 2;
if I = P then
begin G1 := A[P, P] × (A[P, P] - SIGMA) + A[P, P1] ×
A[P1, P] + RHO;
G2 := A[P1, P] × (A[P, P] + A[P1, P1] - SIGMA);
if P1 ≤ N1 then
begin G3 := A[P1, P] × A[P2, P1]; A[P2, P] := 0 end
else G3 := 0
end
else
begin G1 := A[I, IMIN1]; G2 := A[I1, IMIN1];
G3 := if I2 ≤ N then A[I2, IMIN1] else 0
end;
K := if G1 ≥ 0 then
SQRT(G1 ⭡ 2 + G2 ⭡ 2 + G3 ⭡ 2) else
-SQRT(G1 ⭡ 2 + G2 ⭡ 2 + G3 ⭡ 2);
B := ABS(K) > MACHTOL2;
AA := if B then G1 / K + 1 else 2;
PSI1 := if B then G2 / (G1 + K) else 0;
PSI2 := if B then G3 / (G1 + K) else 0;
if I ≠ Q then A[I, IMIN1] := if I = P then
-A[I, IMIN1] else -K;
for J := I step 1 until N do
begin E := AA × (A[I, J] + PSI1 × A[I1, J] +
(if I2 ≤ N then PSI2 × A[I2, J] else 0));
A[I, J] := A[I, J] - E; A[I1, J] := A[I1, J] - PSI1 × E;
if I2 ≤ N then A[I2, J] := A[I2, J] - PSI2 × E
end;
for J := Q step 1 until
(if I2 ≤ N then I2 else N) do
begin E := AA × (A[J, I] + PSI1 × A[J, I1] +
(if I2 ≤ N then PSI2 × A[J, I2] else 0));
A[J, I] := A[J, I] - E; A[J, I1] := A[J, I1] - PSI1 × E;
if I2 ≤ N then A[J, I2] := A[J, I2] - PSI2 × E
end;
if I2 ≤ N1 then
begin I3 := I + 3; E := AA × PSI2 × A[I3, I2];
A[I3, I] := -E;
A[I3, I1] := -PSI1 × E;
A[I3, I2] := A[I3, I2] - PSI2 × E
end
end
end;
if N > 0 then goto IN;
OUT: EM[3] := W; EM[5] := COUNT; COMVALQRI := N
end COMVALQRI;
comment ================== 34191 ================= ;
comment MCA 2421;
procedure COMVECHES(A, N, LAMBDA, MU, EM, U, V);
value N, LAMBDA, MU;
integer N; real LAMBDA, MU; array A, EM, U, V;
begin integer I, I1, J, COUNT, MAX;
real AA, BB, D, M, R, S, W, X, Y, NORM, MACHTOL, TOL;
array G, F[1:N];
Boolean array P[1:N];
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
real procedure MATVEC(L, U, I, A, B); code 34011;
real procedure TAMVEC(L, U, I, A, B); code 34012;
NORM := EM[1]; MACHTOL := EM[0] × NORM; TOL := EM[6] × NORM;
MAX := EM[8];
for I := 2 step 1 until N do
begin F[I - 1] := A[I, I - 1]; A[I, 1] := 0 end;
AA := A[1, 1] - LAMBDA; BB := -MU;
for I := 1 step 1 until N - 1 do
begin I1 := I + 1; M := F[I];
if ABS(M) < MACHTOL then M := MACHTOL;
A[I, I] := M; D := AA ⭡ 2 + BB ⭡ 2; P[I] := ABS(M) < SQRT(D);
if P[I] then
begin comment A[I, J] × FACTOR AND A[I1, J] - A[I, J];
F[I] := R := M × AA / D; G[I] := S := -M × BB / D;
W := A[I1, I]; X := A[I, I1]; A[I1, I] := Y := X × S + W × R;
A[I, I1] := X := X × R - W × S;
AA := A[I1, I1] - LAMBDA - X; BB := -(MU + Y);
for J := I + 2 step 1 until N do
begin W := A[J, I]; X := A[I, J];
A[J, I] := Y := X × S + W × R;
A[I, J] := X := X × R - W × S; A[J, I1] := -Y;
A[I1, J] := A[I1, J] - X
end
end
else
begin comment INTERCHANGE A[I1, J] AND
A[I, J] - A[I1, J] × FACTOR;
F[I] := R := AA / M; G[I] := S := BB / M;
W := A[I1, I1] - LAMBDA; AA := A[I, I1] - R × W - S × MU;
A[I, I1] := W; BB := A[I1, I] - S × W + R × MU;
A[I1, I] := -MU;
for J := I + 2 step 1 until N do
begin W := A[I1, J]; A[I1, J] := A[I, J] - R × W;
A[I, J] := W;
A[J, I1] := A[J, I] - S × W; A[J, I] := 0
end
end
end
P[N] := true; D := AA ⭡ 2 + BB ⭡ 2; if D < MACHTOL ⭡ 2
then begin AA := MACHTOL; BB := 0; D := MACHTOL ⭡ 2 end;
A[N, N] := D; F[N] := AA; G[N] := -BB;
for I := 1 step 1 until N do
begin U[I] := 1; V[I] := 0 end;
COUNT := 0;
FORWARD: if COUNT > MAX then goto OUTM;
for I := 1 step 1 until N do
begin if P[I] then
begin W := V[I]; V[I] := G[I] × U[I] + F[I] × W;
U[I] := F[I] × U[I] - G[I] × W; if I < N then
begin V[I + 1] := V[I + 1] - V[I];
U[I + 1] := U[I + 1] - U[I]
end
end
else
begin AA := U[I + 1]; BB := V[I + 1];
U[I + 1] := U[I] - (F[I] × AA - G[I] × BB); U[I] := AA;
V[I + 1] := V[I] - (G[I] × AA + F[I] × BB); V[I] := BB
end
end FORWARD;
BACKWARD: for I := N step -1 until 1 do
begin I1 := I + 1;
U[I] := (U[I] - MATVEC(I1, N, I, A, U) + (if P[I] then
TAMVEC(I1, N, I, A, V) else A[I1, I] × V[I1])) / A[I, I];
V[I] := (V[I] - MATVEC(I1, N, I, A, V) - (if P[I] then
TAMVEC(I1, N, I, A, U) else A[I1, I] × U[I1])) / A[I, I]
end BACKWARD;
NORMALISE: W := 1 / SQRT(VECVEC(1, N, 0, U, U) +
VECVEC(1, N, 0, V, V));
for J := 1 step 1 until N do
begin U[J] := U[J] × W; V[J] := V[J] × W end;
COUNT := COUNT + 1; if W > TOL then goto FORWARD;
OUTM: EM[7] := W; EM[9] := COUNT
end COMVECHES;
comment ================== 34182 ================= ;
comment MCA 2412;
integer procedure REAEIGVAL(A, N, EM, VAL); value N;
integer N; array A, EM, VAL;
begin integer I, J; real R;
array D[1:N]; integer array INT, INT0[1:N];
procedure TFMREAHES(A, N, EM, INT); code 34170;
procedure EQILBR(A, N, EM, D, INT); code 34173;
integer procedure REAVALQRI(A, N, EM, VAL); code 34180;
EQILBR(A, N, EM, D, INT0); TFMREAHES(A, N, EM, INT);
J := REAEIGVAL := REAVALQRI(A, N, EM, VAL);
for I := J + 1 step 1 until N do
for J := I + 1 step 1 until N do
begin if VAL[J] > VAL[I] then
begin R := VAL[I]; VAL[I] := VAL[J]; VAL[J] := R end
end
end REAEIGVAL;
comment ================== 34184 ================= ;
comment MCA 2414;
integer procedure REAEIG1(A, N, EM, VAL, VEC); value N;
integer N; array A, EM, VAL, VEC;
begin integer I, K, MAX, J, L;
real RESIDU, R, MACHTOL;
array D, V[1:N], B[1:N, 1:N];
integer array INT, INT0[1:N];
procedure TFMREAHES(A, N, EM, INT); code 34170;
procedure BAKREAHES2(A, N, N1, N2, INT, VEC); code 34172;
procedure EQILBR(A, N, EM, D, INT); code 34173;
procedure BAKLBR(N, N1, N2, D, INT, VEC); code 34174;
integer procedure REAVALQRI(A, N, EM, VAL); code 34180;
procedure REAVECHES(A, N, LAMBDA, EM, V); code 34181;
procedure REASCL(A, N, N1, N2); code 34183;
RESIDU := 0; MAX := 0; EQILBR(A, N, EM, D, INT0);
TFMREAHES(A, N, EM, INT);
for I := 1 step 1 until N do
for J := (if I = 1 then 1 else I - 1)
step 1 until N do B[I, J] := A[I, J];
K := REAEIG1 := REAVALQRI(B, N, EM, VAL);
for I := K + 1 step 1 until N do
for J := I + 1 step 1 until N do
begin if VAL[J] > VAL[I] then
begin R := VAL[I]; VAL[I] := VAL[J]; VAL[J] := R end
end;
MACHTOL := EM[0] × EM[1];
for L := K + 1 step 1 until N do
begin if L > 1 then
begin if VAL[L - 1] - VAL[L] < MACHTOL then
VAL[L] := VAL[L - 1] - MACHTOL
end;
for I := 1 step 1 until N do
for J := (if I = 1 then 1 else I - 1)
step 1 until N do B[I, J] := A[I, J];
REAVECHES(B, N, VAL[L], EM, V);
if EM[7] > RESIDU then RESIDU := EM[7];
if EM[9] > MAX then MAX := EM[9];
for J := 1 step 1 until N do VEC[J, L] := V[J]
end;
EM[7] := RESIDU; EM[9] := MAX;
BAKREAHES2(A, N, K + 1, N, INT, VEC);
BAKLBR(N, K + 1, N, D, INT0, VEC);
REASCL(VEC, N, K + 1, N)
end REAEIG1;
comment ================== 34187 ================= ;
comment MCA 2417;
integer procedure REAEIG3(A, N, EM, VAL, VEC); value N;
integer N; array A, EM, VAL, VEC;
begin integer I; real S;
integer array INT, INT0[1:N]; array D[1:N];
procedure TFMREAHES(A, N, EM, INT); code 34170;
procedure BAKREAHES2(A, N, N1, N2, INT, VEC); code 34172;
procedure EQILBR(A, N, EM, D, INT); code 34173;
procedure BAKLBR(N, N1, N2, D, INT, VEC); code 34174;
procedure REASCL(A, N, N1, N2); code 34183;
integer procedure REAQRI(A, N, EM, VAL, VEC); code 34186;
EQILBR(A, N, EM, D, INT0); TFMREAHES(A, N, EM, INT);
I := REAEIG3 := REAQRI(A, N, EM, VAL, VEC);
if I = 0 then
begin BAKREAHES2(A, N, 1, N, INT, VEC);
BAKLBR(N, 1, N, D, INT0, VEC); REASCL(VEC, N, 1, N)
end
end REAEIG3;
comment ================== 34192 ================= ;
comment MCA 2422;
integer procedure COMEIGVAL(A, N, EM, RE, IM); value N;
integer N; array A, EM, RE, IM;
begin integer array INT, INT0[1:N];
array D[1:N];
procedure EQILBR(A, N, EM, D, INT); code 34173;
procedure TFMREAHES(A, N, EM, INT); code 34170;
integer procedure COMVALQRI(A, N, EM, RE, IM);
code 34190;
EQILBR(A, N, EM, D, INT0); TFMREAHES(A, N, EM, INT);
COMEIGVAL := COMVALQRI(A, N, EM, RE, IM)
end COMEIGVAL;
comment ================== 34194 ================= ;
comment MCA 2424;
integer procedure COMEIG1(A, N, EM, RE, IM, VEC);
value N; integer N;
array A, EM, RE, IM, VEC;
begin integer I, J, K, PJ, ITT;
real X, Y, MAX, NEPS;
array AB[1:N, 1:N], D, U, V[1:N];
integer array INT, INT0[1:N];
procedure TRANSFER;
begin integer I, J;
for I := 1 step 1 until N do
for J := (if I = 1 then 1 else I - 1) step 1
until N do AB[I, J] := A[I, J]
end TRANSFER;
procedure EQILBR(A, N, EM, D, INT); code 34173;
procedure TFMREAHES(A, N, EM, INT); code 34170;
procedure BAKREAHES2(A, N, N1, N2, INT, VEC); code 34172;
procedure BAKLBR(N, N1, N2, D, INT, VEC); code 34174;
procedure REAVECHES(A, N, LAMBDA, EM, V); code 34181;
procedure COMSCL(A, N, N1, N2, IM); code 34193;
integer procedure COMVALQRI(A, N, EM, RE, IM);
code 34190;
procedure COMVECHES(A, N, LAMBDA, MU, EM, U, V);
code 34191;
EQILBR(A, N, EM, D, INT0); TFMREAHES(A, N, EM, INT); TRANSFER;
K := COMEIG1 := COMVALQRI(AB, N, EM, RE, IM);
NEPS := EM[0] × EM[1]; MAX := 0; ITT := 0;
for I := K + 1 step 1 until N do
begin X := RE[I]; Y := IM[I]; PJ := 0;
AGAIN: for J := K + 1 step 1 until I - 1 do
begin if ((X - RE[J]) ⭡ 2 +
(Y - IM[J]) ⭡ 2 ≤ NEPS ⭡ 2) then
begin if PJ = J then NEPS := EM[2] × EM[1]
else PJ := J; X := X + 2 × NEPS; goto AGAIN
end
end;
RE[I] := X; TRANSFER; if Y ≠ 0 then
begin COMVECHES(AB, N, RE[I], IM[I], EM, U, V);
for J := 1 step 1 until N do VEC[J, I] := U[J];
I := I + 1; RE[I] := X
end
else REAVECHES(AB, N, X, EM, V);
for J := 1 step 1 until N do VEC[J, I] := V[J];
if EM[7] > MAX then MAX := EM[7];
ITT := if ITT > EM[9] then ITT else EM[9]
end;
EM[7] := MAX; EM[9] := ITT; BAKREAHES2(A, N, K + 1, N, INT, VEC);
BAKLBR(N, K + 1, N, D, INT0, VEC); COMSCL(VEC, N, K + 1, N, IM)
end COMEIG1;
comment ================== 34368 ================= ;
procedure EIGVALHRM(A, N, NUMVAL, VAL, EM); value N, NUMVAL;
integer N, NUMVAL; array A, VAL, EM;
begin array D[1:N], BB[1:N - 1];
procedure HSHHRMTRIVAL(A, N, D, BB, EM); code 34364;
procedure VALSYMTRI(D, BB, N, N1, N2, VAL, EM); code 34151;
HSHHRMTRIVAL(A, N, D, BB, EM);
VALSYMTRI(D, BB, N, 1, NUMVAL, VAL, EM)
end EIGVALHRM;
comment ================== 34369 ================= ;
procedure EIGHRM(A, N, NUMVAL, VAL, VECR, VECI, EM);
value N, NUMVAL; integer N, NUMVAL;
array A, VAL, VECR, VECI, EM;
begin array BB, TR, TI[1:N - 1], D, B[1:N];
procedure HSHHRMTRI(A, N, D, B, BB, EM, TR, TI); code 34363;
procedure VALSYMTRI(D, BB, N, N1, N2, VAL, EM); code 34151;
procedure VECSYMTRI(D, B, N, N1, N2, VAL, VEC, EM); code 34152;
procedure BAKHRMTRI(A, N, N1, N2, VECR, VECI, TR, TI); code 34365;
HSHHRMTRI(A, N, D, B, BB, EM, TR, TI);
VALSYMTRI(D, BB, N, 1, NUMVAL, VAL, EM); B[N] := 0;
VECSYMTRI(D, B, N, 1, NUMVAL, VAL, VECR, EM);
BAKHRMTRI(A, N, 1, NUMVAL, VECR, VECI, TR, TI)
end EIGHRM;
comment ================== 34370 ================= ;
integer procedure QRIVALHRM(A, N, VAL, EM); value N;
integer N; array A, VAL, EM;
begin array B, BB[1:N];
integer I;
procedure HSHHRMTRIVAL(A, N, D, BB, EM); code 34364;
integer procedure QRIVALSYMTRI(D, BB, N, EM); code 34160;
HSHHRMTRIVAL(A, N, VAL, BB, EM); B[N] := BB[N] := 0;
for I := 1 step 1 until N-1 do B[I] := SQRT(BB[I]);
QRIVALHRM := QRIVALSYMTRI(VAL, BB, N, EM)
end QRIVALHRM;
comment ================== 34371 ================= ;
integer procedure QRIHRM(A, N, VAL, VR, VI, EM); value N;
integer N; array A, VAL, VR, VI, EM;
begin integer I, J;
array B, BB[1:N], TR, TI[1:N - 1];
procedure HSHHRMTRI(A, N, D, B, BB, EM, TR, TI); code 34363;
integer procedure QRISYMTRI(A, N, D, B, BB, EM); code 34161;
procedure BAKHRMTRI(A, N, N1, N2, VECR, VECI, TR, TI); code 34365;
HSHHRMTRI(A, N, VAL, B, BB, EM, TR, TI);
for I := 1 step 1 until N do
begin VR[I, I] := 1;
for J := I + 1 step 1 until N do VR[I, J] := VR[J, I] :=
0
end;
B[N] := BB[N] := 0;
I := QRIHRM := QRISYMTRI(VR, N, VAL, B, BB, EM);
BAKHRMTRI(A, N, I + 1, N, VR, VI, TR, TI);
end QRIHRM;
comment ================== 34372 ================= ;
integer procedure VALQRICOM(A1, A2, B, N, EM, VAL1, VAL2);
value N; integer N; array A1, A2, B, EM, VAL1, VAL2;
begin integer M, NM1, I, I1, Q, Q1, MAX, COUNT;
real R, Z1, Z2, DD1, DD2, CC, G1, G2, K1, K2, HC, A1NN,
A2NN, AIJ1, AIJ2, AI1I, KAPPA, NUI, MUI1, MUI2,
MUIM11, MUIM12, NUIM1, TOL;
procedure COMCOLCST(L, U, J, AR, AI, XR, XI); code 34352;
procedure ROTCOMCOL(L, U, I, J, AR, AI, CR, CI, S); code 34357;
procedure ROTCOMROW(L, U, I, J, AR, AI, CR, CI, S); code 34358;
procedure COMKWD(PR, PI, QR, QI, GR, GI, KR, KI); code 34345;
TOL := EM[1] × EM[2]; MAX := EM[4]; COUNT := 0; R := 0;
M := N; if N > 1 then HC := B[N - 1];
IN: NM1 := N - 1;
for I := N, I - 1 while (if I ≥ 1 then ABS(B[I]) > TOL
else false) do Q := I; if Q > 1 then
begin if ABS(B[Q - 1]) > R then R := ABS(B[Q - 1]) end;
if Q = N then
begin VAL1[N] := A1[N, N]; VAL2[N] := A2[N, N]; N := NM1;
if N > 1 then HC := B[N - 1];
end
else
begin DD1 := A1[N, N]; DD2 := A2[N, N]; CC := B[NM1];
COMKWD((A1[NM1, NM1] - DD1) / 2, (A2[NM1, NM1] - DD2)
/ 2, CC × A1[NM1, N], CC × A2[NM1, N], G1, G2, K1,
K2); if Q = NM1 then
begin VAL1[NM1] := G1 + DD1; VAL2[NM1] := G2 + DD2;
VAL1[N] := K1 + DD1; VAL2[N] := K2 + DD2;
N := N - 2; if N > 1 then HC := B[N - 1];
end
else
begin COUNT := COUNT + 1;
if COUNT > MAX then goto OUT; Z1 := K1 + DD1;
Z2 := K2 + DD2;
if ABS(CC) > ABS(HC) then Z1 := Z1 + ABS(CC);
HC := CC / 2; I := Q1 := Q + 1;
AIJ1 := A1[Q, Q] - Z1; AIJ2 := A2[Q, Q] - Z2;
AI1I := B[Q];
KAPPA := SQRT(AIJ1 ⭡ 2 + AIJ2 ⭡ 2 + AI1I ⭡ 2);
MUI1 := AIJ1 / KAPPA; MUI2 := AIJ2 / KAPPA;
NUI := AI1I / KAPPA; A1[Q, Q] := KAPPA;
A2[Q, Q] := 0; A1[Q1, Q1] := A1[Q1, Q1] - Z1;
A2[Q1, Q1] := A2[Q1, Q1] - Z2;
ROTCOMROW(Q1, N, Q, Q1, A1, A2, MUI1, MUI2,
NUI);
ROTCOMCOL(Q, Q, Q, Q1, A1, A2, MUI1, - MUI2, -
NUI); A1[Q, Q] := A1[Q, Q] + Z1;
A2[Q, Q] := A2[Q, Q] + Z2;
for I1 := Q1 + 1 step 1 until N do
begin AIJ1 := A1[I, I]; AIJ2 := A2[I, I];
AI1I := B[I];
KAPPA := SQRT(AIJ1 ⭡ 2 + AIJ2 ⭡ 2 + AI1I ⭡
2); MUIM11 := MUI1; MUIM12 := MUI2;
NUIM1 := NUI; MUI1 := AIJ1 / KAPPA;
MUI2 := AIJ2 / KAPPA; NUI := AI1I / KAPPA;
A1[I1, I1] := A1[I1, I1] - Z1;
A2[I1, I1] := A2[I1, I1] - Z2;
ROTCOMROW(I1, N, I, I1, A1, A2, MUI1,
MUI2, NUI); A1[I, I] := MUIM11 × KAPPA;
A2[I, I] := - MUIM12 × KAPPA;
B[I - 1] := NUIM1 × KAPPA;
ROTCOMCOL(Q, I, I, I1, A1, A2, MUI1, -
MUI2, - NUI); A1[I, I] := A1[I, I] + Z1;
A2[I, I] := A2[I, I] + Z2; I := I1;
end;
AIJ1 := A1[N, N]; AIJ2 := A2[N, N];
KAPPA := SQRT(AIJ1 ⭡ 2 + AIJ2 ⭡ 2);
if (if KAPPA < TOL then true else AIJ2 ⭡ 2
≤ EM[0] × AIJ1 ⭡ 2) then
begin B[NM1] := NUI × AIJ1;
A1[N, N] := AIJ1 × MUI1 + Z1;
A2[N, N] := - AIJ1 × MUI2 + Z2
end
else
begin B[NM1] := NUI × KAPPA; A1NN := MUI1 × KAPPA;
A2NN := - MUI2 × KAPPA; MUI1 := AIJ1 / KAPPA;
MUI2 := AIJ2 / KAPPA;
COMCOLCST(Q, NM1, N, A1, A2, MUI1, MUI2);
A1[N, N] := MUI1 × A1NN - MUI2 × A2NN + Z1;
A2[N, N] := MUI1 × A2NN + MUI2 × A1NN + Z2;
end;
end
end;
if N > 0 then goto IN;
OUT: EM[3] := R; EM[5] := COUNT; VALQRICOM := N;
end VALQRICOM;
comment ================== 34373 ================= ;
integer procedure QRICOM(A1, A2, B, N, EM, VAL1, VAL2, VEC1,
VEC2); value N; integer N;
array A1, A2, B, EM, VAL1, VAL2, VEC1, VEC2;
begin integer M, NM1, I, I1, J, Q, Q1, MAX, COUNT;
real R, Z1, Z2, DD1, DD2, CC, P1, P2, T1, T2, DELTA1,
DELTA2, MV1, MV2, H, H1, H2, G1, G2, K1, K2, HC,
AIJ12, AIJ22, A1NN, A2NN, AIJ1, AIJ2, AI1I, KAPPA,
NUI, MUI1, MUI2, MUIM11, MUIM12, NUIM1, TOL, MACHTOL;
array TF1, TF2[1:N];
procedure COMKWD(PR, PI, QR, QI, GR, GI, KR, KI); code 34345;
procedure ROTCOMROW(L, U, I, J, AR, AI, CR, CI, S); code 34358;
procedure ROTCOMCOL(L, U, I, J, AR, AI, CR, CI, S); code 34357;
procedure COMCOLCST(L, U, J, AR, AI, XR, XI); code 34352;
procedure COMROWCST(L, U, I, AR, AI, XR, XI); code 34353;
real procedure MATVEC(L, U, I, A, B); code 34011;
procedure COMMATVEC(L, U, I, AR, AI, BR, BI, RR, RI); code 34354;
procedure COMDIV(XR, XI, YR, YI, ZR, ZI); code 34342;
TOL := EM[1] × EM[2]; MACHTOL := EM[0] × EM[1];
MAX := EM[4]; COUNT := 0; R := 0; M := N;
if N > 1 then HC := B[N - 1];
for I := 1 step 1 until N do
begin VEC1[I, I] := 1; VEC2[I, I] := 0;
for J := I + 1 step 1 until N do VEC1[I, J] :=
VEC1[J, I] := VEC2[I, J] := VEC2[J, I] := 0
end;
IN: NM1 := N - 1;
for I := N, I - 1 while (if I ≥ 1 then ABS(B[I]) > TOL
else false) do Q := I; if Q > 1 then
begin if ABS(B[Q - 1]) > R then R := ABS(B[Q - 1]) end;
if Q = N then
begin VAL1[N] := A1[N, N]; VAL2[N] := A2[N, N]; N := NM1;
if N > 1 then HC := B[N - 1];
end
else
begin DD1 := A1[N, N]; DD2 := A2[N, N]; CC := B[NM1];
P1 := (A1[NM1, NM1] - DD1) × .5;
P2 := (A2[NM1, NM1] - DD2) × .5;
COMKWD(P1, P2, CC × A1[NM1, N], CC × A2[NM1, N], G1,
G2, K1, K2); if Q = NM1 then
begin A1[N, N] := VAL1[N] := G1 + DD1;
A2[N, N] := VAL2[N] := G2 + DD2;
A1[Q, Q] := VAL1[Q] := K1 + DD1;
A2[Q, Q] := VAL2[Q] := K2 + DD2;
KAPPA := SQRT(K1 ⭡ 2 + K2 ⭡ 2 + CC ⭡ 2);
NUI := CC / KAPPA; MUI1 := K1 / KAPPA;
MUI2 := K2 / KAPPA; AIJ1 := A1[Q, N];
AIJ2 := A2[Q, N]; H1 := MUI1 ⭡ 2 - MUI2 ⭡ 2;
H2 := 2 × MUI1 × MUI2; H := - NUI × 2;
A1[Q, N] := H × (P1 × MUI1 + P2 × MUI2) - NUI ×
NUI × CC + AIJ1 × H1 + AIJ2 × H2;
A2[Q, N] := H × (P2 × MUI1 - P1 × MUI2) + AIJ2 ×
H1 - AIJ1 × H2;
ROTCOMROW(Q + 2, M, Q, N, A1, A2, MUI1, MUI2,
NUI);
ROTCOMCOL(1, Q - 1, Q, N, A1, A2, MUI1, -
MUI2, - NUI);
ROTCOMCOL(1, M, Q, N, VEC1, VEC2, MUI1, -
MUI2, - NUI); N := N - 2;
if N > 1 then HC := B[N - 1]; B[Q] := 0
end
else
begin COUNT := COUNT + 1;
if COUNT > MAX then goto OUT; Z1 := K1 + DD1;
Z2 := K2 + DD2;
if ABS(CC) > ABS(HC) then Z1 := Z1 + ABS(CC);
HC := CC / 2; Q1 := Q + 1; AIJ1 := A1[Q, Q] - Z1;
AIJ2 := A2[Q, Q] - Z2; AI1I := B[Q];
KAPPA := SQRT(AIJ1 ⭡ 2 + AIJ2 ⭡ 2 + AI1I ⭡ 2);
MUI1 := AIJ1 / KAPPA; MUI2 := AIJ2 / KAPPA;
NUI := AI1I / KAPPA; A1[Q, Q] := KAPPA;
A2[Q, Q] := 0; A1[Q1, Q1] := A1[Q1, Q1] - Z1;
A2[Q1, Q1] := A2[Q1, Q1] - Z2;
ROTCOMROW(Q1, M, Q, Q1, A1, A2, MUI1, MUI2,
NUI);
ROTCOMCOL(1, Q, Q, Q1, A1, A2, MUI1, - MUI2, -
NUI); A1[Q, Q] := A1[Q, Q] + Z1;
A2[Q, Q] := A2[Q, Q] + Z2;
ROTCOMCOL(1, M, Q, Q1, VEC1, VEC2, MUI1, -
MUI2, - NUI);
for I := Q1 step 1 until NM1 do
begin I1 := I + 1; AIJ1 := A1[I, I]; AIJ2 := A2[I, I];
AI1I := B[I];
KAPPA := SQRT(AIJ1 ⭡ 2 + AIJ2 ⭡ 2 + AI1I ⭡
2); MUIM11 := MUI1; MUIM12 := MUI2;
NUIM1 := NUI; MUI1 := AIJ1 / KAPPA;
MUI2 := AIJ2 / KAPPA; NUI := AI1I / KAPPA;
A1[I1, I1] := A1[I1, I1] - Z1;
A2[I1, I1] := A2[I1, I1] - Z2;
ROTCOMROW(I1, M, I, I1, A1, A2, MUI1,
MUI2, NUI); A1[I, I] := MUIM11 × KAPPA;
A2[I, I] := - MUIM12 × KAPPA;
B[I - 1] := NUIM1 × KAPPA;
ROTCOMCOL(1, I, I, I1, A1, A2, MUI1, -
MUI2, - NUI); A1[I, I] := A1[I, I] + Z1;
A2[I, I] := A2[I, I] + Z2;
ROTCOMCOL(1, M, I, I1, VEC1, VEC2, MUI1, -
MUI2, - NUI);
end;
AIJ1 := A1[N, N]; AIJ2 := A2[N, N]; AIJ12 := AIJ1 ⭡ 2;
AIJ22 := AIJ2 ⭡ 2; KAPPA := SQRT(AIJ12 + AIJ22);
if (if KAPPA < TOL then true else AIJ22 ≤
EM[0] × AIJ12) then
begin B[NM1] := NUI × AIJ1;
A1[N, N] := AIJ1 × MUI1 + Z1;
A2[N, N] := - AIJ1 × MUI2 + Z2
end
else
begin B[NM1] := NUI × KAPPA; A1NN := MUI1 × KAPPA;
A2NN := - MUI2 × KAPPA; MUI1 := AIJ1 / KAPPA;
MUI2 := AIJ2 / KAPPA;
COMCOLCST(1, NM1, N, A1, A2, MUI1, MUI2);
COMCOLCST(1, NM1, N, VEC1, VEC2, MUI1,
MUI2);
COMROWCST(N + 1, M, N, A1, A2, MUI1, -
MUI2);
COMCOLCST(N, M, N, VEC1, VEC2, MUI1, MUI2);
A1[N, N] := MUI1 × A1NN - MUI2 × A2NN + Z1;
A2[N, N] := MUI1 × A2NN + MUI2 × A1NN + Z2;
end;
end;
end;
if N > 0 then goto IN;
for J := M step - 1 until 2 do
begin TF1[J] := 1; TF2[J] := 0; T1 := A1[J, J]; T2 := A2[J, J];
for I := J - 1 step - 1 until 1 do
begin DELTA1 := T1 - A1[I, I]; DELTA2 := T2 - A2[I, I];
COMMATVEC(I + 1, J, I, A1, A2, TF1, TF2, MV1,
MV2);
if ABS(DELTA1) < MACHTOL ∧ ABS(DELTA2) <
MACHTOL then
begin TF1[I] := MV1 / MACHTOL;
TF2[I] := MV2 / MACHTOL
end
else COMDIV(MV1, MV2, DELTA1, DELTA2, TF1[I],
TF2[I]);
end;
for I := 1 step 1 until M do COMMATVEC(1, J, I,
VEC1, VEC2, TF1, TF2, VEC1[I, J], VEC2[I, J]);
end;
OUT: EM[3] := R; EM[5] := COUNT; QRICOM := N;
end QRICOM;
comment ================== 34374 ================= ;
integer procedure EIGVALCOM(AR, AI, N, EM, VALR, VALI);
value N; integer N; array AR, AI, EM, VALR, VALI;
begin integer array INT[1:N];
array D, B, DEL, TR, TI[1:N];
procedure HSHCOMHES(AR, AI, N, EM, B, TR, TI, DEL); code 34366;
real procedure COMEUCNRM(AR, AI, LW, N); code 34359;
procedure EQILBRCOM(A1, A2, N, EM, D, INT); code 34361;
integer procedure VALQRICOM(A1, A2, B, N, EM, VAL1, VAL2);
code 34372;
EQILBRCOM(AR, AI, N, EM, D, INT);
EM[1] := COMEUCNRM(AR, AI, N - 1, N);
HSHCOMHES(AR, AI, N, EM, B, TR, TI, DEL);
EIGVALCOM := VALQRICOM(AR, AI, B, N, EM, VALR, VALI)
end EIGVALCOM;
comment ================== 34375 ================= ;
integer procedure EIGCOM(AR, AI, N, EM, VALR, VALI, VR, VI);
value N; integer N; array AR, AI, EM, VALR, VALI, VR, VI;
begin integer I;
integer array INT[1:N];
array D, B, DEL, TR, TI[1:N];
procedure EQILBRCOM(A1, A2, N, EM, D, INT); code 34361;
real procedure COMEUCNRM(AR, AI, LW, N); code 34359;
procedure HSHCOMHES(AR, AI, N, EM, B, TR, TI, DEL); code 34366;
integer procedure QRICOM(A1, A2, B, N, EM, VAL1, VAL2, VEC1, VEC2);
code 34373;
procedure BAKCOMHES(AR, AI, TR, TI, DEL, VR, VI, N, N1, N2);
code 34367;
procedure BAKLBRCOM(N, N1, N2, D, INT, VR, VI); code 34362;
procedure SCLCOM(AR, AI, N, N1, N2); code 34360;
EQILBRCOM(AR, AI, N, EM, D, INT);
EM[1] := COMEUCNRM(AR, AI, N - 1, N);
HSHCOMHES(AR, AI, N, EM, B, TR, TI, DEL);
I := EIGCOM := QRICOM(AR, AI, B, N, EM, VALR, VALI, VR,
VI); if I = 0 then
begin BAKCOMHES(AR, AI, TR, TI, DEL, VR, VI, N, 1, N);
BAKLBRCOM(N, 1, N, D, INT, VR, VI);
SCLCOM(VR, VI, N, 1, N)
end
end EIGCOM;
comment ================== 34270 ================= ;
integer procedure QRISNGVALBID(D, B, N, EM);
value N; integer N; array D, B, EM;
begin integer N1, K, K1, I, I1, COUNT, MAX, RNK;
real TOL, BMAX, Z, X, Y, G, H, F, C, S, MIN;
TOL := EM[2] × EM[1]; COUNT := 0; BMAX := 0; MAX := EM[4]; MIN := EM[6];
RNK := N;
IN: K := N; N1 := N - 1;
NEXT: K := K - 1; if K > 0 then
begin if ABS(B[K]) ≥ TOL then
begin if ABS(D[K]) ≥ TOL then goto NEXT;
C := 0; S := 1;
for I := K step 1 until N1 do
begin F := S × B[I]; B[I] := C × B[I]; I1 := I + 1;
if ABS(F) < TOL then goto NEGLECT;
G := D[I1]; D[I1] := H := SQRT(F × F + G × G);
C := G / H; S := - F / H
end;
NEGLECT:
end
else if ABS(B[K]) > BMAX then BMAX := ABS(B[K])
end;
if K = N1 then
begin if D[N] < 0 then D[N] := - D[N];
if D[N] ≤ MIN then RNK := RNK - 1; N := N1
end
else
begin COUNT := COUNT + 1; if COUNT > MAX then goto END;
K1 := K + 1; Z := D[N]; X := D[K1]; Y := D[N1];
G := if N1 = 1 then 0 else B[N1 - 1]; H := B[N1];
F := ((Y - Z) × (Y + Z) + (G - H) × (G + H)) / (2 × H × Y);
G := SQRT(F × F + 1);
F := ((X - Z) × (X + Z) + H × (Y / (if F < 0 then F - G
else F + G) - H)) / X; C := S := 1;
for I := K1 + 1 step 1 until N do
begin I1 := I - 1; G := B[I1]; Y := D[I]; H := S × G; G := C × G;
Z := SQRT(F × F + H × H); C := F / Z; S := H / Z;
if I1 ≠ K1 then B[I1 - 1] := Z; F := X × C + G × S;
G := G × C - X × S; H := Y × S; Y := Y × C;
D[I1] := Z := SQRT(F × F + H × H); C := F / Z; S := H / Z;
F := C × G + S × Y; X := C × Y - S × G
end;
B[N1] := F; D[N] := X
end;
if N > 0 then goto IN;
END: EM[3] := BMAX; EM[5] := COUNT; EM[7] := RNK; QRISNGVALBID := N
end QRISNGVALBID;
comment ================== 34271 ================= ;
integer procedure QRISNGVALDECBID(D, B, M, N, U, V, EM);
value M, N; integer M, N; array D, B, U, V, EM;
begin integer N0, N1, K, K1, I, I1, COUNT, MAX, RNK;
real TOL, BMAX, Z, X, Y, G, H, F, C, S, MIN;
procedure ROTCOL(L, U, I, J, A, C, S);
value L, U, I, J, C, S; integer L, U, I, J;
real C, S; array A;
code 34040;
TOL := EM[2] × EM[1]; COUNT := 0; BMAX := 0; MAX := EM[4]; MIN := EM[6];
RNK := N0 := N;
IN: K := N; N1 := N - 1;
NEXT: K := K - 1; if K > 0 then
begin if ABS(B[K]) ≥ TOL then
begin if ABS(D[K]) ≥ TOL then goto NEXT;
C := 0; S := 1;
for I := K step 1 until N1 do
begin F := S × B[I]; B[I] := C × B[I]; I1 := I + 1;
if ABS(F) < TOL then goto NEGLECT;
G := D[I1]; D[I1] := H := SQRT(F × F + G × G);
C := G / H; S := - F / H;
ROTCOL(1, M, K, I1, U, C, S)
end;
NEGLECT:
end
else if ABS(B[K]) > BMAX then BMAX := ABS(B[K])
end;
if K = N1 then
begin if D[N] < 0 then
begin D[N] := - D[N];
for I := 1 step 1 until N0 do V[I, N] := - V[I, N]
end;
if D[N] ≤ MIN then RNK := RNK - 1; N := N1
end
else
begin COUNT := COUNT + 1; if COUNT > MAX then goto END;
K1 := K + 1; Z := D[N]; X := D[K1]; Y := D[N1];
G := if N1 = 1 then 0 else B[N1 - 1]; H := B[N1];
F := ((Y - Z) × (Y + Z) + (G - H) × (G + H)) / (2 × H × Y);
G := SQRT(F × F + 1);
F := ((X - Z) × (X + Z) + H × (Y / (if F < 0 then F - G
else F + G) - H)) / X; C := S := 1;
for I := K1 + 1 step 1 until N do
begin I1 := I - 1; G := B[I1]; Y := D[I]; H := S × G; G := C × G;
Z := SQRT(F × F + H × H); C := F / Z; S := H / Z;
if I1 ≠ K1 then B[I1 - 1] := Z; F := X × C + G × S;
G := G × C - X × S; H := Y × S; Y := Y × C;
ROTCOL(1, N0, I1, I, V, C, S);
D[I1] := Z := SQRT(F × F + H × H); C := F / Z; S := H / Z;
F := C × G + S × Y; X := C × Y - S × G;
ROTCOL(1, M, I1, I, U, C, S)
end;
B[N1] := F; D[N] := X
end;
if N > 0 then goto IN;
END: EM[3] := BMAX; EM[5] := COUNT; EM[7] := RNK; QRISNGVALDECBID := N
end QRISNGVALDECBID;
comment ================== 34272 ================= ;
integer procedure QRISNGVAL(A, M, N, VAL, EM);
value M, N; integer M, N; array A, VAL, EM;
begin array B[1:N];
procedure HSHREABID(A, M, N, D, B, EM);
value M, N; integer M, N; array D, B, EM;
code 34260;
integer procedure QRISNGVALBID(D, B, N, EM);
value N; integer N; array D, B, EM;
code 34270;
HSHREABID(A, M, N, VAL, B, EM);
QRISNGVAL := QRISNGVALBID(VAL, B, N, EM)
end QRISNGVAL;
comment ================== 34273 ================= ;
integer procedure QRISNGVALDEC(A, M, N, VAL, V, EM);
value M, N; integer M, N; array A, VAL, V, EM;
begin array B[1:N];
procedure HSHREABID(A, M, N, D, B, EM);
value M, N; integer M, N; array A, D, B, EM;
code 34260;
procedure PSTTFMMAT(A, N, V, B);
value N; integer N; array A, V, B;
code 34261;
procedure PRETFMMAT(A, M, N, D);
value M, N; integer M, N; array A, D;
code 34262;
integer procedure QRISNGVALDECBID(D, B, M, N, U, V, EM);
value M, N; integer M, N; array D, B, U, V, EM;
code 34271;
HSHREABID(A, M, N, VAL, B, EM);
PSTTFMMAT(A, N, V, B); PRETFMMAT(A, M, N, VAL);
QRISNGVALDEC := QRISNGVALDECBID(VAL, B, M, N, A, V, EM)
end QRISNGVALDEC;
comment ================== 34345 ================= ;
procedure COMKWD(PR, PI, QR, QI, GR, GI, KR, KI);
value PR, PI, QR, QI; real PR, PI, QR, QI, GR, GI, KR, KI;
begin
procedure COMMUL (AR, AI, BR, BI, RR, RI);
code 34341;
procedure COMDIV(XR, XI, YR, YI, ZR, ZI);
code 34342;
procedure COMSQRT(AR, AI, PR, PI);
code 34343;
if QR = 0 ∧ QI = 0 then
begin KR := KI := 0 ; GR := PR × 2; GI := PI × 2 end else
if PR = 0 ∧ PI = 0 then
begin COMSQRT(QR, QI, GR, GI); KR := -GR; KI := -GI end else
begin real HR, HI;
if ABS(PR) > 1 ∨ ABS(PI) > 1 then begin
COMDIV(QR, QI, PR, PI, HR, HI);
COMDIV(HR, HI, PR, PI, HR, HI);
COMSQRT(1 + HR, HI, HR, HI);
COMMUL(PR, PI, HR + 1, HI, GR, GI);
end else begin COMSQRT(QR + (PR + PI) × (PR-PI), QI + PR × PI × 2, HR, HI);
if PR × HR + PI × HI > 0 then
begin GR := PR + HR; GI := PI + HI end else
begin GR := PR - HR; GI := PI - HI end;
end;
COMDIV(-QR, -QI, GR, GI, KR, KI);
end
end COMKWD;
comment ================== 32010 ================= ;
real procedure EULER(AI, I, EPS, TIM);
value EPS, TIM; integer I, TIM; real AI, EPS;
begin integer K, N, T; real MN, MP, DS, SUM; array M[0:15];
N := T := 0; I := 0; M[0] := AI; SUM := M[0] / 2;
NEXT TERM: I := I + 1; MN := AI;
for K := 0 step 1 until N do
begin MP := (MN + M[K]) / 2; M[K] := MN; MN := MP end;
if ABS(MN) < ABS(M[N]) ∧ N < 15 then
begin DS := MN / 2; N := N + 1; M[N] := MN end else DS := MN;
SUM := SUM + DS; T := if ABS(DS) < EPS then T + 1 else 0;
if T < TIM then go to NEXT TERM;
EULER := SUM
end EULER;
comment ================== 32020 ================= ;
real procedure SUMPOSSERIES(AI, I, MAXADDUP, MAXZERO, MAXRECURS,
MACHEXP, TIM);
value MAXADDUP, MAXZERO, MAXRECURS, MACHEXP, TIM;
real AI, I, MAXZERO; integer MAXADDUP, MAXRECURS, MACHEXP, TIM;
begin integer RECURS, VL, VL2, VL4;
real procedure EULER(AI, I, EPS, TIM); code 32010;
real procedure SUMUP(AI, I); real AI, I;
begin integer J; real SUM, NEXTTERM;
I := MAXADDUP + 1; J := 1;
CHECK ADD: if AI ≤ MAXZERO then
begin if J < TIM then
begin J := J + 1; I := I + 1; go to CHECK ADD end
end else
if RECURS ≠ MAXRECURS then go to TRANSFORMSERIES;
SUM := 0; I := 0; J := 0;
ADD LOOP: I := I + 1; NEXTTERM := AI;
J := if NEXTTERM ≤ MAXZERO then J + 1 else 0;
SUM := SUM + NEXTTERM;
if J < TIM then go to ADD LOOP;
SUMUP := SUM; go to GOTSUM;
TRANSFORMSERIES:
begin Boolean JODD; integer J2; array V[1:VL];
real procedure BJK(J, K); value J, K; real K;
integer J;
begin real COEFF;
if K > MACHEXP then BJK := 0 else
begin COEFF := 2 ⭡ (K - 1); I := J × COEFF;
BJK := COEFF × AI
end
end BJK;
real procedure VJ(J); value J; integer J;
begin real TEMP, K;
if JODD then
begin JODD := false; RECURS := RECURS + 1;
TEMP := VJ := SUMUP(BJK(J, K), K);
RECURS := RECURS - 1;
if J ≤ VL then V[J] := TEMP else
if J ≤ VL2 then V[J - VL] := TEMP
end else
begin JODD := true; if J > VL4 then
begin RECURS := RECURS + 1;
VJ := - SUMUP(BJK(J, K), K); RECURS := RECURS - 1
end else
begin J2 := J2 + 1; I := J2;
if J > VL2 then VJ := - (V[J2 - VL] - AI) / 2
else
begin TEMP := V[ if J ≤ VL then J else
J - VL] := (V[J2] - AI) / 2; VJ := - TEMP
end
end
end
end VJ;
J2 := 0;
JODD := true; SUMUP := EULER(VJ(J + 1), J, MAXZERO, TIM)
end TRANSFORMSERIES;
GOTSUM:
end SUMUP;
RECURS := 0; VL := 1000; VL2 := 2 × VL; VL4 := 2 × VL2;
SUMPOSSERIES := SUMUP(AI, I)
end SUMPOSSERIES;
comment ================== 32070 ================= ;
real procedure QADRAT(X, A, B, FX, E);
value A, B; real X, A, B, FX; array E;
begin real F0, F2, F3, F5, F6, F7, F9,
F14, V, W, HMIN, HMAX, RE, AE;
real procedure LINT(X0, XN, F0, F2, F3, F5, F6, F7, F9, F14);
real X0, XN, F0, F2, F3, F5, F6, F7, F9, F14;
begin real H, XM, F1, F4, F8, F10, F11, F12, F13;
XM := (X0 + XN) / 2; H := (XN - X0) / 32; X := XM + 4 × H;
F8 := FX; X := XN - 4 × H; F11 := FX; X := XN - 2 × H; F12 := FX;
V := 0.330580178199226 × F7 + 0.173485115707338 × (F6 + F8) +
0.321105426559972 × (F5 + F9) + 0.135007708341042 × (F3 + F11)
+ 0.165714514228223 × (F2 + F12) + 0.39397146063812710-1 × (F0
+ F14); X := X0 + H; F1 := FX; X := XN - H; F13 := FX;
W := 0.260652434656970 × F7 + 0.239063286684765 × (F6 + F8) +
0.263062635477467 × (F5 + F9) + 0.218681931383057 × (F3 + F11)
+ 0.27578976466428410-1 × (F2 + F12) + 0.105575010053846 × (F1
+ F13) + 0.15711942605951810-1 × (F0 + F14);
if ABS(H) < HMIN then E[3] := E[3] + 1;
if ABS(V - W) < ABS(W) × RE + AE ∨ ABS(H) < HMIN
then LINT := H × W else
begin X := X0 + 6 × H; F4 := FX; X := XN - 6 × H; F10 := FX;
V := 0.245673430093324 × F7 + 0.255786258286921 × (F6 + F8) +
0.228526063690406 × (F5 + F9) + 0.50055713152546010-1 × (F4 +
F10) + 0.177946487736780 × (F3 + F11) + 0.58401459934744910-1
× (F2 + F12) + 0.87483094287133110-1 × (F1 + F13) +
0.18964207864807910-1 × (F0 + F14);
LINT := if ABS(V - W) < ABS(V) × RE + AE then H × V
else
LINT(X0, XM, F0, F1, F2, F3, F4, F5, F6, F7) - LINT(XN,
XM, F14, F13, F12, F11, F10, F9, F8, F7)
end
end LINT;
HMAX := (B - A) / 16; if HMAX = 0 then
begin QADRAT := 0; goto RETURN end;
RE := E[1]; AE := 2 × E[2] / ABS(B - A); E[3] := 0;
HMIN := ABS(B - A) × RE; X := A; F0 := FX;
X := A + HMAX; F2 := FX; X := A + 2 × HMAX; F3 := FX;
X := A + 4 × HMAX; F5 := FX; X := A + 6 × HMAX; F6 := FX;
X := A + 8 × HMAX; F7 := FX; X := B - 4 × HMAX; F9 := FX; X := B;
F14 := FX;
QADRAT := LINT(A, B, F0, F2, F3, F5, F6, F7, F9, F14) × 16;
RETURN:
end QADRAT;
comment ================== 32051 ================= ;
real procedure INTEGRAL(X, A, B, FX, E, UA, UB);
value A, B; real X, A, B, FX; array E; Boolean UA, UB;
begin
real procedure TRANSF;
begin Z := 1 / X; X := Z + B1; TRANSF := FX × Z × Z end;
real procedure QAD(FX); real FX;
begin real T, V, SUM, HMIN;
procedure INT;
begin real X3, X4, F3, F4, H;
X4 := X2; X2 := X1; F4 := F2; F2 := F1;
ANEW: X := X1 := (X0 + X2) × .5; F1 := FX;
X := X3 := (X2 + X4) × .5; F3 := FX; H := X4 - X0;
V := (4 × (F1 + F3) + 2 × F2 + F0 + F4) × 15;
T := 6 × F2 -4 × (F1 + F3) + F0 + F4;
if ABS(T) < ABS(V) × RE + AE then
SUM := SUM + (V - T) × H else
if ABS(H) < HMIN then E[3] := E[3] + 1
else
begin INT; X2 := X3; F2 := F3; goto ANEW end;
X0 := X4; F0 := F4
end INT;
HMIN := ABS(X0 - X2) × RE; X := X1 := (X0 + X2) × .5;
F1 := FX; SUM := 0; INT; QAD := SUM / 180
end QAD;
real X0, X1, X2, F0, F1, F2, RE, AE, B1, Z;
RE := E[1]; if UB then AE := E[2] × 180 / ABS(B - A)
else AE := E[2] × 90 / ABS(B - A); if UA then
begin E[3] := E[4] := 0; X := X0 := A; F0 := FX end
else
begin X := X0 := A := E[5]; F0 := E[6] end;
E[5] := X := X2 := B; E[6] := F2 := FX; E[4] := E[4] + QAD(FX);
if ¬UB then
begin if A < B then
begin B1 := B -1 ; X0 := 1 end
else
begin B1 := B + 1 ; X0 := -1 end;
F0 := E[6]; E[5] := X2 := 0; E[6] := F2 := 0;
AE := E[2] × 90;
E[4] := E[4] - QAD(TRANSF)
end;
INTEGRAL := E[4]
end INTEGRAL;
comment ================== 34210 ================= ;
procedure LINEMIN(N, X, D, ND, ALFA, G, FUNCT, F0, F1, DF0, DF1,
EVLMAX, STRONGSEARCH, IN); value N, ND, F0, DF0, STRONGSEARCH;
integer N, EVLMAX; Boolean STRONGSEARCH;
real ND, ALFA, F0, F1, DF0, DF1;
array X, D, G, IN;
real procedure FUNCT;
begin integer I, EVL;
Boolean NOTININT;
real F, OLDF, DF, OLDDF, MU, ALFA0, Q, W, Y, Z, RELTOL, ABSTOL
, EPS, AID;
array X0[1:N];
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
procedure ELMVEC(L, U, SHIFT, A, B, X); code 34020;
procedure DUPVEC(L, U, SHIFT, A, B); code 31030;
RELTOL := IN[1]; ABSTOL := IN[2]; MU := IN[3]; EVL := 0;
ALFA0 := 0; OLDF := F0; OLDDF := DF0; Y := ALFA; NOTININT := true;
DUPVEC(1, N, 0, X0, X);
EPS := (SQRT(VECVEC(1, N, 0, X, X)) × RELTOL + ABSTOL) / ND;
Q := (F1 - F0) / (ALFA × DF0);
INT: if NOTININT then NOTININT := DF1 < 0 ∧ Q > MU;
AID := ALFA; if DF1 ≥ 0 then
begin Z := 3 × (OLDF - F1) / ALFA + OLDDF + DF1;
W := SQRT(Z ⭡ 2 - OLDDF × DF1);
ALFA := ALFA × (1 - (DF1 + W - Z) / (DF1 - OLDDF + W × 2));
if ALFA < EPS then ALFA := EPS else
if AID - ALFA < EPS then ALFA := AID - EPS
end CUBIC INTERPOLATION
else if NOTININT then
begin ALFA0 := ALFA := Y; OLDDF := DF1; OLDF := F1 end
else ALFA := 0.5 × ALFA; Y := ALFA + ALFA0;
DUPVEC(1, N, 0, X, X0); ELMVEC(1, N, 0, X, D, Y);
EPS := (SQRT(VECVEC(1, N, 0, X, X)) × RELTOL + ABSTOL) / ND;
F := FUNCT(N, X, G); EVL := EVL + 1 ; DF := VECVEC(1, N, 0, D, G);
Q := (F - F0) / (Y × DF0);
if (if NOTININT ∨ STRONGSEARCH then true else
Q < MU ∨ Q > 1 - MU) ∧ EVL < EVLMAX then
begin if NOTININT ∨ DF > 0 ∨ Q < MU then
begin DF1 := DF; F1 := F end
else
begin ALFA0 := Y; ALFA := AID - ALFA; OLDDF := DF; OLDF := F
end;
if ALFA > EPS × 2 then goto INT
end;
ALFA := Y; EVLMAX := EVL; DF1 := DF; F1 := F
end LINEMIN;
comment ================== 34211 ================= ;
procedure RNK1UPD(H, N, V, C); value N, C; integer N;
real C; array H, V;
begin integer J, K;
procedure ELMVEC(L, U, SHIFT, A, B, X); code 34020;
K := 0;
for J := 1, J + K while K < N do
begin K := K + 1 ;
ELMVEC(J, J + K - 1, 1 - J, H, V, V[K] × C)
end
end RNK1UPD;
comment ================== 34212 ================= ;
procedure DAVUPD(H, N, V, W, C1, C2); value N, C1, C2;
integer N; real C1, C2; array H, V, W;
begin integer I, J, K;
real VK, WK;
K := 0;
for J := 1, J + K while K < N do
begin K := K + 1 ; VK := V[K] × C1; WK := W[K] × C2;
for I := 0 step 1 until K -1 do
H[I + J] := H[I + J] + V[I + 1] × VK - W[I + 1] × WK
end
end DAVUPD;
comment ================== 34213 ================= ;
procedure FLEUPD(H, N, V, W, C1, C2); value N, C1, C2;
integer N; real C1, C2; array H, V, W;
begin integer I, J, K;
real VK, WK;
K := 0; for J := 1, J + K while K < N do
begin K := K + 1; VK := - W[K] × C1 + V[K] × C2; WK := V[K] × C1;
for I := 0 step 1 until K - 1 do
H[I + J] := H[I + J] + V[I + 1] × VK -W[I + 1] × WK
end
end FLEUPD;
comment ================== 33010 ================= ;
procedure RK1(X, A, B, Y, YA, FXY, E, D, FI);
value B, FI; real X, A, B, Y, YA, FXY; Boolean FI;
array E, D;
begin real E1, E2, XL, YL, H, INT, HMIN, ABSH, K0, K1,
K2, K3, K4, K5, DISCR, TOL, MU, MU1, FH, HL;
Boolean LAST, FIRST, REJECT;
if FI then
begin D[3] := A; D[4] := YA end;
D[1] := 0; XL := D[3]; YL := D[4];
if FI then D[2] := B - D[3]; ABSH := H := ABS(D[2]);
if B - XL < 0 then H := - H; INT := ABS(B - XL);
HMIN := INT × E[1] + E[2]; E1 := E[1] / INT;
E2 := E[2] / INT; FIRST := true; if FI then
begin LAST := true; goto STEP end;
TEST: ABSH := ABS(H); if ABSH < HMIN then
begin H := if H > 0 then HMIN else - HMIN; ABSH := HMIN
end;
if H ≥ B - XL equiv H ≥ 0 then
begin D[2] := H; LAST := true; H := B - XL;
ABSH := ABS(H)
end
else LAST := false;
STEP: X := XL; Y := YL; K0 := FXY × H;
X := XL + H / 4.5; Y := YL + K0 / 4.5;
K1 := FXY × H; X := XL + H / 3;
Y := YL + (K0 + K1 × 3) / 12; K2 := FXY × H;
X := XL + H × .5; Y := YL + (K0 + K2 × 3) / 8;
K3 := FXY × H; X := XL + H × .8;
Y := YL + (K0 × 53 - K1 × 135 + K2 × 126 + K3 × 56)
/ 125; K4 := FXY × H; X := if LAST then B else XL + H;
Y := YL + (K0 × 133 - K1 × 378 + K2 × 276 + K3 × 112
+ K4 × 25) / 168; K5 := FXY × H;
DISCR := ABS(K0 × 21 - K2 × 162 + K3 × 224 - K4 × 125
+ K5 × 42) / 14; TOL := ABS(K0) × E1 + ABSH × E2;
REJECT := DISCR > TOL; MU := TOL / (TOL + DISCR) + .45;
if REJECT then
begin if ABSH ≤ HMIN then
begin D[1] := D[1] + 1; Y := YL; FIRST := true;
goto NEXT
end;
H := MU × H; goto TEST
end;
if FIRST then
begin FIRST := false; HL := H; H := MU × H; goto ACC
end;
FH := MU × H / HL + MU - MU1; HL := H; H := FH × H;
ACC: MU1 := MU;
Y := YL + ( - K0 × 63 + K1 × 189 - K2 × 36 - K3 × 112
+ K4 × 50) / 28; K5 := FXY × HL;
Y := YL + (K0 × 35 + K2 × 162 + K4 × 125 + K5 × 14)
/ 336;
NEXT: if B ≠ X then
begin XL := X; YL := Y; goto TEST end;
if ¬LAST then D[2] := H; D[3] := X; D[4] := Y
end RK1;
comment ================== 33033 ================= ;
procedure RKE (X, XE, N, Y, DER, DATA, FI, OUT);
value FI, N; integer N; real X, XE;
Boolean FI; array Y, DATA;
procedure DER, OUT;
begin integer J;
real XT, H, HMIN, INT, HL, HT, ABSH, FHM, DISCR, TOL, MU,
MU1, FH, E1, E2;
Boolean LAST, FIRST, REJECT;
array K0, K1, K2, K3, K4[1:N];
if FI then
begin DATA[3] := XE - X; DATA[4] := DATA[5] := DATA[6] := 0 end;
ABSH := H := ABS(DATA[3]);
if XE < X then H := - H; INT := ABS(XE - X);
HMIN := INT × DATA[1] + DATA[2];
E1 := 12 × DATA[1] / INT; E2 := 12 × DATA[2] / INT;
FIRST := true; REJECT := false; if FI then
begin LAST := true; goto STEP end;
TEST: ABSH := ABS(H); if ABSH < HMIN then
begin H := SIGN (XE - X) × HMIN; ABSH := HMIN end;
if H ≥ XE - X equiv H ≥ 0 then
begin LAST := true; H := XE - X; ABSH := ABS(H) end
else LAST := false;
STEP: if ¬REJECT then
begin for J := 1 step 1 until N do K0[J] := Y[J];
DER(X, K0)
end;
HT := .184262134833347 × H; XT := X + HT;
for J := 1 step 1 until N do K1[J] := K0[J] × HT + Y[J];
DER(XT, K1);
HT := .69098300562505310-1 × H; XT := 4 × HT + X;
for J := 1 step 1 until N do K2[J] :=
(3 × K1[J] + K0[J]) × HT + Y[J];
DER(XT, K2);
XT := .5 × H + X; HT := .1875 × H;
for J := 1 step 1 until N do K3[J] := ((1.74535599249993
× K2[J] - K1[J]) × 2.23606797749979 + K0[J]) × HT + Y[J];
DER(XT, K3);
XT := .723606797749979 × H + X; HT := .4 × H;
for J := 1 step 1 until N do K4[J] := (((.517595468166681
× K0[J] - K1[J]) × .927050983124840 + K2[J]) × 1.46352549156242
+ K3[J]) × HT + Y[J];
DER(XT, K4);
XT := if LAST then XE else X + H; HT := 2 × H;
for J := 1 step 1 until N do K1[J] := ((((2 × K4[J] +
K2[J]) × .412022659166595 + K1[J]) × 2.23606797749979 -
K0[J]) × .375 - K3[J]) × HT + Y[J];
DER(XT, K1);
REJECT := false; FHM := 0;
for J := 1 step 1 until N do
begin DISCR := ABS((1.6 × K3[J] - K2[J] - K4[J]) × 5 +
K0[J] + K1[J]);
TOL := ABS(K0[J]) × E1 + E2;
REJECT := DISCR > TOL ∨ REJECT;
FH := DISCR / TOL; if FH > FHM then FHM := FH
end;
MU := 1 / (1 + FHM) + .45; if REJECT then
begin DATA[5] := DATA[5] + 1; if ABSH ≤ HMIN then
begin DATA[6] := DATA[6] + 1; HL := H; REJECT := false;
FIRST := true; goto NEXT
end;
H := MU × H; goto TEST
end;
if FIRST then
begin FIRST := false; HL := H; H := MU × H; goto ACC
end;
FH := MU × H / HL + MU - MU1; HL := H; H := FH × H;
ACC: MU1 := MU; HT := HL / 12;
for J := 1 step 1 until N do Y[J] :=
((K2[J] + K4[J]) × 5 + K0[J] + K1[J]) × HT + Y[J];
NEXT: DATA[3] := HL; DATA[4] := DATA[4] + 1; X := XT; OUT;
if X ≠ XE then goto TEST
end RKE;
comment ================== 33016 ================= ;
procedure RK4A(X, XA, B, Y, YA, FXY, E, D, FI, XDIR,
POS); value FI, XDIR, POS; Boolean FI, XDIR, POS;
real X, XA, B, Y, YA, FXY; array E, D;
begin integer I;
Boolean IV, FIRST, FIR, REJ;
real K0, K1, K2, K3, K4, K5, FHM, ABSH, DISCR, S, XL,
COND0, S1, COND1, YL, HMIN, H, ZL, TOL, HL, MU, MU1;
array E1[1:2];
Boolean procedure ZEROIN(X, Y, FX, EPS) ; real X, Y, FX, EPS ;
code 34150 ;
procedure RKSTEP(X, XL, H, Y, YL, ZL, FXY, D);
value XL, YL, ZL, H; real X, XL, H, Y, YL, ZL, FXY;
integer D;
begin if D = 2 then goto INTEGRATE; if D = 3 then
begin X := XL; Y := YL; K0 := FXY × H end
else if D = 1 then K0 := ZL × H else K0 := K0 × MU;
X := XL + H / 4.5; Y := YL + K0 / 4.5; K1 := FXY × H;
X := XL + H / 3; Y := YL + (K0 + K1 × 3) / 12;
K2 := FXY × H; X := XL + H × .5;
Y := YL + (K0 + K2 × 3) / 8; K3 := H × FXY;
X := XL + H × .8;
Y := YL + (K0 × 53 - K1 × 135 + K2 × 126 + K3 ×
56) / 125; K4 := FXY × H; if D ≤ 1 then
begin X := XL + H;
Y := YL + (K0 × 133 - K1 × 378 + K2 × 276 + K3
× 112 + K4 × 25) / 168; K5 := FXY × H;
DISCR := ABS(K0 × 21 - K2 × 162 + K3 × 224 - K4
× 125 + K5 × 42) / 14; goto END
end;
INTEGRATE: X := XL + H;
Y := YL + ( - K0 × 63 + K1 × 189 - K2 × 36 - K3 ×
112 + K4 × 50) / 28; K5 := FXY × H;
Y := YL + (K0 × 35 + K2 × 162 + K4 × 125 + K5 ×
14) / 336;
END:
end RKSTEP;
real procedure FZERO;
begin if IV then
begin if S = XL then FZERO := COND0 else if S = S1
then FZERO := COND1 else
begin RKSTEP(X, XL, S - XL, Y, YL, ZL, FXY, 3);
FZERO := B
end
end
else
begin if S = YL then FZERO := COND0 else if S = S1
then FZERO := COND1 else
begin RKSTEP(Y, YL, S - YL, X, XL, ZL, 1 /
FXY, 3); FZERO := B
end
end
end FZERO;
if FI then
begin D[3] := XA; D[4] := YA; D[0] := 1 end;
D[1] := 0; X := XL := D[3]; Y := YL := D[4]; IV := D[0] > 0;
FIRST := FIR := true; HMIN := E[0] + E[1];
H := E[2] + E[3]; if H < HMIN then HMIN := H;
CHANGE: ZL := FXY; if ABS(ZL) ≤ 1 then
begin if ¬IV then
begin D[2] := H := H / ZL; D[0] := 1;
IV := FIRST := true
end;
if FIR then goto A; I := 1; goto AGAIN
end
else
begin if IV then
begin if ¬FIR then D[2] := H := H × ZL; D[0] := - 1;
IV := false; FIRST := true
end;
if FIR then
begin H := E[0] + E[1];
A: if (if FI then (if IV equiv XDIR then H else
H × ZL) < 0 equiv POS else H × D[2] < 0) then H := - H
end;
I := 1
end;
AGAIN: ABSH := ABS(H); if ABSH < HMIN then
begin H := SIGN(H) × HMIN; ABSH := HMIN end;
if IV then
begin RKSTEP(X, XL, H, Y, YL, ZL, FXY, I);
TOL := E[2] × ABS(K0) + E[3] × ABSH
end
else
begin RKSTEP(Y, YL, H, X, XL, 1 / ZL, 1 / FXY, I);
TOL := E[0] × ABS(K0) + E[1] × ABSH
end;
REJ := DISCR > TOL; MU := TOL / (TOL + DISCR) + .45;
if REJ then
begin if ABSH ≤ HMIN then
begin if IV then
begin X := XL + H; Y := YL + K0 end
else
begin X := XL + K0; Y := YL + H end;
D[1] := D[1] + 1; FIRST := true; goto NEXT
end;
H := H × MU; I := 0; goto AGAIN
end REJ;
if FIRST then
begin FIRST := FIR; HL := H; H := MU × H; goto ACCEPT
end;
FHM := MU × H / HL + MU - MU1; HL := H; H := FHM × H;
ACCEPT: if IV then RKSTEP(X, XL, HL, Y, YL, ZL, FXY,
2) else RKSTEP(Y, YL, HL, X, XL, ZL, 1 / FXY, 2);
MU1 := MU;
NEXT: if FIR then
begin FIR := false; COND0 := B;
if ¬(FI ∨ REJ) then H := D[2]
end
else
begin D[2] := H; COND1 := B;
if COND0 × COND1 ≤ 0 then goto ZERO;
COND0 := COND1
end;
D[3] := XL := X; D[4] := YL := Y; goto CHANGE;
ZERO: E1[1] := E[4]; E1[2] := E[5];
S1 := if IV then X else Y;
S := if IV then XL else YL ;
ZEROIN(S, S1, FZERO, ABS(E1[1] × S) + ABS(E1[2])) ;
S1 := if IV then X else Y ;
if IV then RKSTEP(X, XL, S - XL, Y, YL, ZL, FXY, 3)
else RKSTEP(Y, YL, S - YL, X, XL, ZL, 1 / FXY,
3); D[3] := X; D[4] := Y
end RK4A;
comment ================== 33017 ================= ;
procedure RK4NA(X, XA, B, FXJ, J, E, D, FI, N, L, POS);
value FI, N, L, POS; integer J, N, L; Boolean FI, POS;
real B, FXJ; array X, XA, E, D;
begin integer I, IV, IV0;
Boolean FIR, FIRST, REJ;
real H, COND0, COND1, FHM, ABSH, TOL, FH, MAX, X0,
X1, S, HMIN, HL, MU, MU1;
array XL, DISCR, Y[0:N], K[0:5, 0:N], E1[1:2];
Boolean procedure ZEROIN(X, Y, FX, EPS) ; real X, Y, FX, EPS ;
code 34150 ;
procedure RKSTEP(H, D); value H, D; integer D; real H;
begin integer I;
procedure F(T); value T; integer T;
begin integer I;
real P;
for J := 1 step 1 until N do Y[J] := FXJ;
P := H / Y[IV];
for I := 0 step 1 until N do
begin if I ≠ IV then K[T, I] := Y[I] × P end
end F;
if D = 2 then goto INTEGRATE; if D = 3 then
begin for I := 0 step 1 until N do X[I] := XL[I];
F(0)
end
else if D = 1 then
begin real P;
P := H / Y[IV];
for I := 0 step 1 until N do
begin if I ≠ IV then K[0, I] := P × Y[I] end
end
else
for I := 0 step 1 until N do
begin if I ≠ IV then K[0, I] := K[0, I] × MU end;
for I := 0 step 1 until N do X[I] := XL[I] + (if I
= IV then H else K[0, I]) / 4.5; F(1);
for I := 0 step 1 until N do X[I] := XL[I] + (if I
= IV then H × 4 else (K[0, I] + K[1, I] × 3)) / 12;
F(2);
for I := 0 step 1 until N do X[I] := XL[I] + (if I
= IV then H × .5 else (K[0, I] + K[2, I] × 3) / 8);
F(3);
for I := 0 step 1 until N do X[I] := XL[I] + (if I
= IV then H × .8 else (K[0, I] × 53 - K[1, I] × 135
+ K[2, I] × 126 + K[3, I] × 56) / 125); F(4);
if D ≤ 1 then
begin for I := 0 step 1 until N do X[I] := XL[I] +
(if I = IV then H else (K[0, I] × 133 -
K[1, I] × 378 + K[2, I] × 276 + K[3, I] × 112 +
K[4, I] × 25) / 168); F(5);
for I := 0 step 1 until N do
begin if I ≠ IV then DISCR[I] := ABS(K[0, I] × 21
- K[2, I] × 162 + K[3, I] × 224 - K[4, I] ×
125 + K[5, I] × 42) / 14
end;
goto END
end;
INTEGRATE: for I := 0 step 1 until N do X[I] := XL[I]
+ (if I = IV then H else ( - K[0, I] × 63 + K[1, I]
× 189 - K[2, I] × 36 - K[3, I] × 112 + K[4, I] × 50)
/ 28); F(5);
for I := 0 step 1 until N do
begin if I ≠ IV then X[I] := XL[I] + (K[0, I] × 35
+ K[2, I] × 162 + K[4, I] × 125 + K[5, I] × 14) / 336
end ;
END:
end RKSTEP ;
real procedure FZERO;
begin if S = X0 then FZERO := COND0 else if S = X1
then FZERO := COND1 else
begin RKSTEP(S - XL[IV], 3); FZERO := B end
end FZERO;
if FI then
begin for I := 0 step 1 until N do D[I + 3] := XA[I];
D[0] := D[2] := 0
end;
D[1] := 0;
for I := 0 step 1 until N do X[I] := XL[I] := D[I + 3];
IV := D[0]; H := D[2]; FIRST := FIR := true; Y[0] := 1;
goto CHANGE;
AGAIN: ABSH := ABS(H); if ABSH < HMIN then
begin H := if H > 0 then HMIN else - HMIN;
ABSH := ABS(H)
end;
RKSTEP(H, I); REJ := false; FHM := 0;
for I := 0 step 1 until N do
begin if I ≠ IV then
begin TOL := E[2 × I] × ABS(K[0, I]) + E[2 × I + 1]
× ABSH; REJ := TOL < DISCR[I] ∨ REJ;
FH := DISCR[I] / TOL; if FH > FHM then FHM := FH
end
end;
MU := 1 / (1 + FHM) + .45; if REJ then
begin if ABSH ≤ HMIN then
begin for I := 0 step 1 until N do
begin if I ≠ IV then X[I] := XL[I] + K[0, I]
else X[I] := XL[I] + H
end;
D[1] := D[1] + 1; FIRST := true; goto NEXT
end;
H := H × MU; I := 0; goto AGAIN
end;
if FIRST then
begin FIRST := FIR; HL := H; H := MU × H; goto ACCEPT
end;
FH := MU × H / HL + MU - MU1; HL := H; H := FH × H;
ACCEPT: RKSTEP(HL, 2); MU1 := MU;
NEXT: if FIR then
begin FIR := false; COND0 := B;
if ¬(FI ∨ REJ) then H := D[2]
end
else
begin D[2] := H; COND1 := B;
if COND0 × COND1 ≤ 0 then goto ZERO;
COND0 := COND1
end;
for I := 0 step 1 until N do D[I + 3] := XL[I] := X[I];
CHANGE: IV0 := IV;
for J := 1 step 1 until N do Y[J] := FXJ;
MAX := ABS(Y[IV]);
for I := 0 step 1 until N do
begin if ABS(Y[I]) > MAX then
begin MAX := ABS(Y[I]); IV := I end
end;
if IV0 ≠ IV then
begin FIRST := true; D[0] := IV;
D[2] := H := Y[IV] / Y[IV0] × H
end;
X0 := XL[IV]; if FIR then
begin HMIN := E[0] + E[1];
for I := 1 step 1 until N do
begin H := E[2 × I] + E[2 × I + 1];
if H < HMIN then HMIN := H
end;
H := E[2 × IV] + E[2 × IV + 1];
if (FI ∧ (Y[L]/Y[IV] × H < 0 equiv POS)) ∨
( ¬FI ∧ D[2] × H < 0) then H := -H
end;
I := 1; goto AGAIN;
ZERO: E1[1] := E[2 × N + 2]; E1[2] := E[2 × N + 3];
X1 := X[IV] ; S := X0 ;
ZEROIN(S, X1, FZERO, ABS(E1[1] × S) + ABS(E1[2])) ; X0 := S ; X1 := X[IV];
RKSTEP(X0 - XL[IV], 3);
for I := 0 step 1 until N do D[I + 3] := X[I]
end RK4NA;
comment ================== 33080 ================= ;
Boolean procedure MULTISTEP(X, XEND, Y, HMIN, HMAX, YMAX, EPS,
FIRST, SAVE, DERIV, AVAILABLE, JACOBIAN, STIFF, N, OUT);
value HMIN, HMAX, EPS, XEND, N, STIFF;
Boolean FIRST, AVAILABLE, STIFF;
integer N;
real X, XEND, HMIN, HMAX, EPS;
array Y, YMAX, SAVE, JACOBIAN;
procedure DERIV, OUT;
begin own Boolean ADAMS, WITH JACOBIAN;
own integer M, SAME, KOLD;
own real XOLD, HOLD, A0, TOLUP, TOL, TOLDWN, TOLCONV;
Boolean EVALUATE, EVALUATED, DECOMPOSE, DECOMPOSED, CONV;
integer I, J, L, K, KNEW, FAILS;
real H, CH, CHNEW, ERROR, DFI, C;
array A[0:5], DELTA, LAST DELTA, DF[1:N], JAC[1:N, 1:N], AUX[1:3];
integer array P[1:N];
real procedure MATVEC(L, U, I, A, B); code 34011;
real procedure DEC(A, N, AUX, P); code 34300;
procedure SOL(A, N, P, B); code 34051;
real procedure NORM2(AI); real AI;
begin real S, A; S := 1.010-100;
for I := 1 step 1 until N do
begin A := AI/YMAX[I]; S := S + A × A end;
NORM2 := S
end NORM2;
procedure RESET;
begin if CH < HMIN/HOLD then CH := HMIN/HOLD else
if CH > HMAX/HOLD then CH := HMAX/HOLD;
X := XOLD; H := HOLD × CH; C := 1;
for J := 0 step M until K × M do
begin for I := 1 step 1 until N do
Y[J + I] := SAVE[J + I] × C;
C := C × CH
end;
DECOMPOSED := false
end RESET;
procedure METHOD;
begin I := -39;
if ADAMS then
begin for C := 1, 1, 144, 4, 0, .5, 1, .5, 576, 144, 1, 5/12, 1,
.75, 1/6, 1436, 576, 4, .375, 1, 11/12, 1/3, 1/24,
2844, 1436, 1, 251/720, 1, 25/24, 35/72,
5/48, 1/120, 0, 2844, 0.1
do begin I := I + 1; SAVE[I] := C end
end else
begin for C := 1, 1, 9, 4, 0, 2/3, 1, 1/3, 36, 20.25, 1, 6/11,
1, 6/11, 1/11, 84.028, 53.778, 0.25, .48, 1, .7, .2, .02,
156.25, 108.51, .027778, 120/274, 1, 225/274,
85/274, 15/274, 1/274, 0, 187.69, .0047361
do begin I := I + 1; SAVE[I] := C end
end
end METHOD;
procedure ORDER;
begin C := EPS × EPS; J := (K-1) × (K + 8)/2 - 38;
for I := 0 step 1 until K do A[I] := SAVE[I + J];
TOLUP := C × SAVE[J + K + 1];
TOL := C × SAVE[J + K + 2];
TOLDWN := C × SAVE[J + K + 3];
TOLCONV := EPS/(2 × N × (K + 2));
A0 := A[0]; DECOMPOSE := true;
end ORDER;
procedure EVALUATE JACOBIAN;
begin EVALUATE := false;
DECOMPOSE := EVALUATED := true;
if AVAILABLE then else
begin real D; array FIXY, FIXDY, DY[1:N];
for I := 1 step 1 until N do
FIXY[I] := Y[I];
DERIV(FIXDY);
for J := 1 step 1 until N do
begin D := if EPS > ABS(FIXY[J])
then EPS × EPS
else EPS × ABS(FIXY[J]);
Y[J] := Y[J] + D; DERIV(DY);
for I := 1 step 1 until N do
JACOBIAN[I, J] := (DY[I]-FIXDY[I])/D;
Y[J] := FIXY[J]
end
end
end EVALUATE JACOBIAN;
procedure DECOMPOSE JACOBIAN;
begin DECOMPOSE := false;
DECOMPOSED := true; C := -A0 × H;
for J := 1 step 1 until N do
begin for I := 1 step 1 until N do
JAC[I, J] := JACOBIAN[I, J] × C;
JAC[J, J] := JAC[J, J] + 1
end;
AUX[2] := 1.010-12;
DEC(JAC, N, AUX, P)
end DECOMPOSE JACOBIAN;
procedure CALCULATE STEP AND ORDER;
begin real A1, A2, A3;
A1 := if K ≤ 1 then 0 else
0.75 × (TOLDWN/NORM2(Y[K × M + I])) ⭡ (0.5/K);
A2 := 0.80 × (TOL/ERROR) ⭡ (0.5/(K + 1));
A3 := if K ≥ 5 ∨ FAILS ≠ 0
then 0 else
0.70 × (TOLUP/NORM2(DELTA[I] - LAST DELTA[I])) ⭡
(0.5/(K + 2));
if A1 > A2 ∧ A1 > A3 then
begin KNEW := K-1; CHNEW := A1 end else
if A2 > A3 then
begin KNEW := K ; CHNEW := A2 end else
begin KNEW := K + 1; CHNEW := A3 end
end CALCULATE STEP AND ORDER;
if FIRST then
begin FIRST := false; M := N;
for I := -1, -2, -3 do SAVE[I] := 0;
OUT(0, 0);
ADAMS := ¬STIFF; WITH JACOBIAN := ¬ADAMS;
if WITH JACOBIAN then EVALUATE JACOBIAN;
METHOD;
NEW START: K := 1; SAME := 2; ORDER; DERIV(DF);
H := if ¬WITH JACOBIAN then HMIN else
SQRT(2 × EPS/SQRT(NORM2 (MATVEC(1, N, I, JACOBIAN, DF))));
if H > HMAX then H := HMAX else
if H < HMIN then H := HMIN;
XOLD := X; HOLD := H; KOLD := K; CH := 1;
for I := 1 step 1 until N do
begin SAVE[I] := Y[I]; SAVE[M + I] := Y[M + I] := DF[I] × H
end;
OUT(0, 0)
end else
begin WITH JACOBIAN := ¬ADAMS; CH := 1;
K := KOLD; RESET; ORDER;
DECOMPOSE := WITH JACOBIAN
end;
FAILS := 0;
for L := 0 while X < XEND do
begin if X + H ≤ XEND then X := X + H else
begin H := XEND-X; X := XEND; CH := H/HOLD; C := 1;
for J := M step M until K × M do
begin C := C × CH;
for I := J + 1 step 1 until J + N do
Y[I] := Y[I] × C
end;
SAME := if SAME < 3 then 3 else SAME + 1;
end;
comment PREDICTION;
for L := 1 step 1 until N do
begin for I := L step M until (K-1) × M + L do
for J := (K-1) × M + L step -M until I do
Y[J] := Y[J] + Y[J + M];
DELTA[L] := 0
end; EVALUATED := false;
comment CORRECTION AND ESTIMATION LOCAL ERROR;
for L := 1, 2, 3 do
begin DERIV(DF);
for I := 1 step 1 until N do
DF[I] := DF[I] × H - Y[M + I];
if WITH JACOBIAN then
begin if EVALUATE then EVALUATE JACOBIAN;
if DECOMPOSE then DECOMPOSE JACOBIAN;
SOL(JAC, N, P, DF)
end;
CONV := true;
for I := 1 step 1 until N do
begin DFI := DF[I];
Y[ I] := Y[ I] + A0 × DFI;
Y[M + I] := Y[M + I] + DFI;
DELTA[I] := DELTA[I] + DFI;
CONV := CONV ∧ ABS(DFI) < TOLCONV × YMAX[I]
end;
if CONV then
begin ERROR := NORM2(DELTA[I]);
goto CONVERGENCE
end
end;
comment ACCEPTANCE OR REJECTION;
if ¬CONV then
begin if ¬WITH JACOBIAN then
begin EVALUATE := WITH JACOBIAN := SAME ≥ K
∨ H < 1.1 × HMIN;
if ¬WITH JACOBIAN then CH := CH/4;
end else
if ¬DECOMPOSED then DECOMPOSE := true else
if ¬EVALUATED then EVALUATE := true else
if H > 1.1 × HMIN then CH := CH/4 else
if ADAMS then goto TRY CURTISS else
begin SAVE[-1] := 1; goto RETURN end;
RESET
end else CONVERGENCE:
if ERROR > TOL then
begin FAILS := FAILS + 1;
if H > 1.1 × HMIN then
begin if FAILS > 2 then
begin if ADAMS then
begin ADAMS := false; METHOD end;
KOLD := 0; RESET; goto NEW START
end else
begin CALCULATE STEP AND ORDER;
if KNEW ≠ K then
begin K := KNEW; ORDER end;
CH := CH × CHNEW; RESET
end
end else
begin if ADAMS then TRY CURTISS:
begin ADAMS := false; METHOD
end else
if K = 1 then
begin comment VIOLATE EPS CRITERION;
C := EPS × SQRT(ERROR/TOL);
if C > SAVE[-3] then SAVE[-3] := C;
SAVE[-2] := SAVE[-2] + 1;
SAME := 4; goto ERROR TEST OK
end;
K := KOLD := 1; RESET; ORDER; SAME := 2
end
end else ERROR TEST OK:
begin
FAILS := 0;
for I := 1 step 1 until N do
begin C := DELTA[I];
for L := 2 step 1 until K do
Y[L × M + I] := Y[L × M + I] + A[L] × C;
if ABS(Y[I]) > YMAX[I] then
YMAX[I] := ABS(Y[I])
end;
SAME := SAME-1;
if SAME = 1 then
begin for I := 1 step 1 until N do
LAST DELTA[I] := DELTA[I]
end else
if SAME = 0 then
begin CALCULATE STEP AND ORDER;
if CHNEW > 1.1 then
begin DECOMPOSED := false;
if K ≠ KNEW then
begin if KNEW > K then
begin for I := 1 step 1
until N do Y[KNEW × M + I]
:= DELTA[I] × A[K]/KNEW
end;
K := KNEW; ORDER
end;
SAME := K + 1;
if CHNEW × H > HMAX
then CHNEW := HMAX/H;
H := H × CHNEW; C := 1;
for J := M step M until K × M do
begin C := C × CHNEW;
for I := J + 1 step 1 until
J + N do Y[I] := Y[I] × C
end
end
else SAME := 10
end;
if X ≠ XEND then
begin XOLD := X; HOLD := H; KOLD := K; CH := 1;
for I := K × M + N step -1 until 1 do
SAVE[I] := Y[I];
OUT(H, K)
end
end CORRECTION AND ESTIMATION LOCAL ERROR;
end STEP;
RETURN: SAVE[0] := if ADAMS then 0 else 1;
MULTISTEP := SAVE[-1] = 0 ∧ SAVE[-2] = 0
end MULTISTEP;
comment ================== 33180 ================= ;
procedure DIFFSYS(X, XE, N, Y, DERIVATIVE, AETA, RETA, S, H0, OUTPUT);
value N;
integer N;
real X, XE, AETA, RETA, H0;
array Y, S;
procedure DERIVATIVE, OUTPUT;
begin real A, B, B1, C, G, H, U, V, TA, FC; integer I, J, K, KK, JJ, L, M, R, SR;
array YA, YL, YM, DY, DZ[1:N], DT[1:N, 0:6], D[0:6], YG, YH[0:7, 1:N];
Boolean KONV, B0, BH, LAST;
LAST := false; H := H0;
NEXT: if H × 1.1 ≥ XE-X then
begin LAST := true; H0 := H; H := XE-X + 10-13 end;
DERIVATIVE(X, Y, DZ); BH := false;
for I := 1 step 1 until N do YA[I] := Y[I];
ANF: A := H + X; FC := 1.5; B0 := false; M := 1; R := 2; SR := 3; JJ := -1;
for J := 0 step 1 until 9 do
begin if B0 then
begin D[1] := 16/9; D[3] := 64/9; D[5] := 256/9 end
else begin D[1] := 9/4; D[3] := 9; D[5] := 36 end;
KONV := true;
if J > 6 then begin L := 6; D[6] := 64; FC := .6 × FC end
else begin L := J; D[L] := M × M end;
M := M × 2; G := H/M; B := G × 2;
if BH ∧ J < 8 then
begin for I := 1 step 1 until N do
begin YM[I] := YH[J, I]; YL[I] := YG[J, I] end
end
else
begin
KK := (M-2)/2; M := M-1;
for I := 1 step 1 until N do
begin YL[I] := YA[I]; YM[I] := YA[I] + G × DZ[I] end;
for K := 1 step 1 until M do
begin DERIVATIVE(X + K × G, YM, DY);
for I := 1 step 1 until N do
begin U := YL[I] + B × DY[I]; YL[I] := YM[I]; YM[I] := U;
U := ABS(U); if U > S[I] then S[I] := U
end;
if K = KK ∧ K ≠ 2 then
begin JJ := JJ + 1; for I := 1 step 1 until N do
begin YH[JJ, I] := YM[I]; YG[JJ, I] := YL[I] end
end
end
end;
DERIVATIVE(A, YM, DY);
for I := 1 step 1 until N do
begin V := DT[I, 0]; TA := C := DT[I, 0] := (YM[I] + YL[I] + G × DY[I])/2;
for K := 1 step 1 until L do
begin B1 := D[K] × V; B := B1-C; U := V;
if B ≠ 0 then
begin B := (C-V)/B; U := C × B; C := B1 × B end;
V := DT[I, K]; DT[I, K] := U; TA := U + TA
end;
if ABS(Y[I]-TA) > RETA × S[I] + AETA then KONV := false;
Y[I] := TA
end;
if KONV then goto END;
D[2] := 4; D[4] := 16; B0 := ¬B0; M := R; R := SR; SR := M × 2
end;
BH := ¬BH; LAST := false; H := H/2; goto ANF;
END: H := FC × H; X := A; OUTPUT; if ¬LAST then goto NEXT;
end DIFFSYS;
comment ================== 33061 ================= ;
procedure ARK (T, TE, M0, M, U, DERIVATIVE, DATA, OUT);
integer M0, M;
real T, TE;
array U, DATA;
procedure DERIVATIVE, OUT;
begin integer P, N, Q;
own real EC0, EC1, EC2, TAU0, TAU1, TAU2, TAUS, T2;
real THETANM1, TAU, BETAN, QINV, ETA;
array MU, LAMBDA[1:DATA[1]], THETHA[0:DATA[1]], RO, R[M0:M];
Boolean START, STEP1, LAST;
procedure INIVEC(L, U, A, X); code 31010;
procedure MULVEC(L, U, SHIFT, A, B, X); code 31020;
procedure DUPVEC(L, U, SHIFT, A, B); code 31030;
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
procedure ELMVEC(L, U, SHIFT, A, B, X); code 34020;
procedure DECSOL(A, N, AUX, B); code 34301;
procedure INITIALIZE;
begin integer I, J, K, L, N1; real S, THETA0;
array ALFA[1:8, 1:DATA[1] + 1], TH[1:8], AUX[1:3];
real procedure LABDA(I, J); value I, J; integer I, J;
LABDA := if P < 3 then (if J = I-1 then MUI(I) else 0)
else if P = 3 then (if I = N then (if J = 0
then .25 else if J = N - 1 then .75
else 0) else if J = 0 then (if I = 1
then MUI(1) else .25) else if J = I - 1
then LAMBDA[I] else 0) else 0;
real procedure MUI(I); value I; integer I;
MUI := if I = N then 1 else
if I < 1 ∨ I > N then 0 else
if P < 3 then LAMBDA[I] else
if P = 3 then LAMBDA[I] + .25 else 0;
real procedure SUM(I, A, B, X);
value B; integer I, A, B; real X;
begin real S; S := 0;
for I := A step 1 until B do S := S + X;
SUM := S
end SUM;
N := DATA[1]; P := DATA[2]; EC1 := EC2 := 0;
BETAN := DATA[3];
THETANM1 := if P = 3 then .75 else 1;
THETA0 := 1 - THETANM1; S := 1;
for J := N - 1 step - 1 until 1 do
begin S := - S × THETA0 + DATA[N + 10 - J];
MU[J] := DATA[N + 11 - J] / S;
LAMBDA[J] := MU[J] - THETA0
end;
for I := 1 step 1 until 8 do
for J := 0 step 1 until N do
ALFA[I, J + 1] := if I = 1 then 1 else
if J = 0 then 0 else if I = 2 ∨ I = 4 ∨ I = 8 then
MUI(J) ⭡ ENTIER((I + 2) / 3) else
if (I = 3 ∨ I = 6) ∧ J > 1 then SUM(L, 1, J-1,
LABDA(J, L) × MUI(L) ⭡ ENTIER(I / 3)) else
if I = 5 ∧ J > 2 then SUM(L, 2, J - 1, LABDA(J, L) ×
SUM(K, 1, L - 1, LABDA(L, K) × MUI(K))) else
if I = 7 ∧ J > 1 then SUM(L, 1, J - 1, LABDA(J, L) ×
MUI(L)) × MUI(J) else 0;
N1 := if N < 4 then N + 1 else if N < 7 then 4
else 8;
I := 1;
for S := 1, .5, 1 / 6, 1 / 3, 1 / 24, 1 / 12, .125, .25 do
begin TH[I] := S; I := I + 1 end;
if P = 3 ∧ N < 7 then TH[1] := TH[2] := 0;
AUX[2] := 10-14; DECSOL(ALFA, N1, AUX, TH);
INIVEC(0, N, THETHA, 0);
DUPVEC(0, N1 - 1, 1, THETHA, TH);
if ¬(P = 3 ∧ N < 7) then
begin THETHA[0] := THETHA[0] - THETA0;
THETHA[N - 1] := THETHA[N - 1] - THETANM1; Q := P + 1
end else Q := 3;
QINV := 1 / Q;
START := DATA[8] = 0; DATA[10] := 0; LAST := false;
DUPVEC(M0, M, 0, R, U); DERIVATIVE(T, R)
end INITIALIZE;
procedure LOCAL ERROR CONSTRUCTION(I); value I; integer I;
begin if THETHA[I] ≠ 0 then
ELMVEC(M0, M, 0, RO, R, THETHA[I]);
if I = N then
begin DATA[9] := SQRT(VECVEC(M0, M, 0, RO, RO)) × TAU;
EC0 := EC1; EC1 := EC2; EC2 := DATA[9] / TAU ⭡ Q
end
end LEC;
procedure STEPSIZE;
begin real TAUACC, TAUSTAB, AA, BB, CC, EC;
ETA := SQRT(VECVEC(M0, M, 0, U, U)) × DATA[7] + DATA[6];
if ETA > 0 then
begin if START then
begin if DATA[8] = 0 then
begin TAUACC := DATA[5];
STEP1 := true
end else if STEP1 then
begin TAUACC := (ETA / EC2) ⭡ QINV;
if TAUACC > 10 × TAU2 then
TAUACC := 10 × TAU2 else STEP1 := false
end else
begin BB := (EC2 - EC1) / TAU1; CC := - BB × T2 + EC2;
EC := BB × T + CC;
TAUACC := if EC < 0 then TAU2 else
(ETA / EC) ⭡ QINV;
START := false
end
end else
begin AA := ((EC0 - EC1) / TAU0 + (EC2 - EC1) / TAU1)
/ (TAU1 + TAU0);
BB := (EC2 - EC1) / TAU1 - (2 × T2 - TAU1) × AA;
CC := - (AA × T2 + BB) × T2 + EC2;
EC := (AA × T + BB) × T + CC;
TAUACC := if EC < 0 then
TAUS else (ETA / EC) ⭡ QINV;
if TAUACC > 2 × TAUS then TAUACC := 2 × TAUS;
if TAUACC < TAUS / 2 then TAUACC := TAUS / 2
end
end else TAUACC := DATA[5];
if TAUACC < DATA[5] then TAUACC := DATA[5];
TAUSTAB := BETAN / DATA[4]; if TAUSTAB < DATA[5] then
begin DATA[10] := 1; goto ENDARK end;
TAU := if TAUACC > TAUSTAB then TAUSTAB else TAUACC;
TAUS := TAU; if TAU ≥ TE - T then
begin TAU := TE - T; LAST := true end;
TAU0 := TAU1; TAU1 := TAU2; TAU2 := TAU
end STEPSIZE;
procedure DIFFERENCE SCHEME;
begin integer I, J;
real MT, LT;
MULVEC(M0, M, 0, RO, R, THETHA[0]);
if P = 3 then ELMVEC(M0, M, 0, U, R, .25 × TAU);
for I := 1 step 1 until N - 1 do
begin MT := MU[I] × TAU; LT := LAMBDA[I] × TAU;
for J := M0 step 1 until M do
R[J] := LT × R[J] + U[J];
DERIVATIVE(T + MT, R); LOCAL ERROR CONSTRUCTION(I)
end;
ELMVEC(M0, M, 0, U, R, THETANM1 × TAU);
DUPVEC(M0, M, 0, R, U); DERIVATIVE(T + TAU, R);
LOCAL ERROR CONSTRUCTION(N); T2 := T;
if LAST then
begin LAST := false; T := TE end else T := T + TAU;
DATA[8] := DATA[8] + 1
end DIFSCH;
INITIALIZE;
NEXT STEP:
STEPSIZE; DIFFERENCE SCHEME; OUT;
if T ≠ TE then goto NEXT STEP;
ENDARK:
end ARK;
comment ================== 33070 ================= ;
procedure EFRK(T, TE, M0, M, U, SIGMA, PHI, DIAMETER, DERIVATIVE, K, STEP, R, L,
BETA, THIRDORDER, TOL, OUTPUT);
value R, L;
integer M0, M, K, R, L;
real T, TE, SIGMA, PHI, DIAMETER, STEP, TOL;
array U, BETA;
Boolean THIRDORDER;
procedure DERIVATIVE, OUTPUT;
begin integer N;
real THETA0, THETANM1, H, B, B0, PHI0, PHIL, PI, COSPHI, SINPHI, EPS, BETAR;
Boolean FIRST, LAST, COMPLEX, CHANGE;
integer array P[1:L];
real array MU, LABDA[0:R + L-1], PT[0:R], FAC, BETAC[0:L-1], RL[M0:M],
A[1:L, 1:L], AUX[0:3];
procedure ELMVEC(L, U, SHIFT, A, B, X); code 34020;
procedure SOL(A, N, P, B); code 34051;
procedure DEC(A, N, AUX, P); code 34300;
procedure FORM CONSTANTS;
begin integer I;
FIRST := false;
FAC[0] := 1;
for I := 1 step 1 until L-1 do FAC[I] := I × FAC[I-1];
PT[R] := L × FAC[L-1];
for I := 1 step 1 until R do
PT[R-I] := PT[R-I + 1] × (L + I)/I
end FORM CONSTANTS;
procedure FORM BETA;
begin integer I, J; real BB, C, D;
if FIRST then FORM CONSTANTS;
if L = 1 then
begin C := 1-EXP(-B);
for J := 1 step 1 until R do C := BETA[J]-C/B;
BETA[R + 1] := C/B
end else
if B > 40 then
begin for I := R + 1 step 1 until R + L do
begin C := 0;
for J := 0 step 1 until R do
C := BETA[J] × PT[J]/(I-J)-C/B;
BETA[I] := C/B/FAC[L + R-I]/FAC[I-R-1]
end;
end else
begin D := C := EXP(-B); BETAC[L-1] := D/FAC[L-1];
for I := 1 step 1 until L-1 do
begin C := B × C/I; D := D + C; BETAC[L-1-I] := D/FAC[L-1-I] end;
BB := 1;
for I := R + 1 step 1 until R + L do
begin C := 0;
for J := 0 step 1 until R do
C := (BETA[J]-(if J < L then BETAC[J] else 0)) ×
PT[J]/(I-J)-C/B;
BETA[I] := C/B/FAC[L + R-I]/FAC[I-R-1] +
(if I < L then BB × BETAC[I] else 0);
BB := BB × B
end
end
end FORM BETA;
procedure SOLUTION OF COMPLEX EQUATIONS;
begin integer I, J, C1, C3;
real C2, E, B1, ZI, COSIPHI, SINIPHI, COSPHIL;
real array D[1:L];
procedure ELEMENTS OF MATRIX;
begin PHIL := PHI0;
COSPHI := COS(PHIL); SINPHI := SIN(PHIL);
COSIPHI := 1; SINIPHI := 0;
for I := 0 step 1 until L-1 do
begin C1 := R + 1 + I; C2 := 1;
for J := L-1 step -2 until 1 do
begin A[J, L-I] := C2 × COSIPHI;
A[J + 1, L-I] := C2 × SINIPHI;
C2 := C1 × C2; C1 := C1-1
end;
COSPHIL := COSIPHI × COSPHI-SINIPHI × SINPHI;
SINIPHI := COSIPHI × SINPHI + SINIPHI × COSPHI;
COSIPHI := COSPHIL
end;
AUX[2] := 0; DEC(A, L, AUX, P)
end EL OF MAT;
procedure RIGHTHANDSIDE;
begin E := EXP(B × COSPHI);
B1 := B × SINPHI-(R + 1) × PHIL;
COSIPHI := E × COS(B1); SINIPHI := E × SIN(B1);
B1 := 1/B; ZI := B1⭡R;
for J := L step -2 until 2 do
begin D[J] := ZI × SINIPHI;
D[J-1] := ZI × COSIPHI;
COSPHIL := COSIPHI × COSPHI-SINIPHI × SINPHI;
SINIPHI := COSIPHI × SINPHI + SINIPHI × COSPHI;
COSIPHI := COSPHIL;
ZI := ZI × B
end;
COSIPHI := ZI := 1; SINIPHI := 0;
for I := R step -1 until 0 do
begin C1 := I; C2 := BETA[I];
C3 := if 2 × I > L-2 then 2 else L-2 × I;
COSPHIL := COSIPHI × COSPHI-SINIPHI × SINPHI;
SINIPHI := COSIPHI × SINPHI + SINIPHI × COSPHI;
COSIPHI := COSPHIL;
for J := L step -2 until C3 do
begin D[J] := D[J] + ZI × C2 × SINIPHI;
D[J-1] := D[J-1]-ZI × C2 × COSIPHI;
C2 := C2 × C1; C1 := C1-1
end;
ZI := ZI × B1
end
end RIGHT HAND SIDE;
if PHI0 ≠ PHIL then ELEMENTS OF MATRIX;
RIGHTHANDSIDE;
SOL(A, L, P, D);
for I := 1 step 1 until L do BETA[R + I] := D[L + 1-I] × B1
end SOLOFCOMEQ;
procedure COEFFICIENT;
begin integer J, K; real C;
B0 := B; PHI0 := PHI;
if B ≥ 1 then
begin if COMPLEX then SOLUTION OF COMPLEX EQUATIONS
else FORM BETA
end;
LABDA[0] := MU[0] := 0;
if THIRDORDER then
begin THETA0 := .25; THETANM1 := .75;
if B < 1 then
begin C := MU[N-1] := 2/3; LABDA[N-1] := 5/12;
for J := N-2 step -1 until 1 do
begin C := MU[J] := C/(C-.25)/(N-J + 1);
LABDA[J] := C-.25
end
end else
begin C := MU[N-1] := BETA[2] × 4/3; LABDA[N-1] := C-.25;
for J := N-2 step -1 until 1 do
begin C := MU[J] := C/(C-.25) × BETA[N-J + 1]/BETA[N-J]/
(if J < L then B else 1);
LABDA[J] := C-.25
end
end
end else
begin THETA0 := 0; THETANM1 := 1;
if B < 1 then
begin for J := N-1 step -1 until 1 do
MU[J] := LABDA[J] := 1/(N-J + 1)
end else
begin LABDA[N-1] := MU[N-1] := BETA[2];
for J := N-2 step -1 until 1 do
MU[J] := LABDA[J] := BETA[N-J + 1]/BETA[N-J]/
(if J < L then B else 1)
end
end
end COEFFICIENT;
procedure STEPSIZE;
begin real D, HSTAB, HSTABINT;
H := STEP;
D := ABS(SIGMA × SIN(PHI));
COMPLEX := L÷2 × 2 = L ∧ 2 × D > DIAMETER;
if DIAMETER > 0 then
HSTAB := (SIGMA⭡2/(DIAMETER × (DIAMETER × .25 + D)))⭡(L × .5/R)/
BETAR/SIGMA
else HSTAB := H;
D := if THIRDORDER then (2 × TOL/EPS/BETA[R])⭡(1/(N-1)) ×
4⭡((L-1)/(N-1)) else (TOL/EPS)⭡(1/R)/BETAR;
HSTABINT := ABS(D/SIGMA);
if H > HSTAB then H := HSTAB;
if H > HSTABINT then H := HSTABINT;
if T + H > TE × (1-K × EPS) then
begin LAST := true; H := TE-T end;
B := H × SIGMA; D := DIAMETER × .1 × H; D := D × D;
if H < T × EPS then goto ENDOFEFRK;
CHANGE := B0 = -1 ∨ ((B-B0) × (B-B0) + B × B0 × (PHI-PHI0) × (PHI-PHI0) > D)
end STEPSIZE;
procedure DIFFERENCESCHEME ;
begin integer I, J; real MT, LT, THT;
I := -1;
NEXTTERM:
I := I + 1; MT := MU[I] × H; LT := LABDA[I] × H;
for J := M0 step 1 until M do RL[J] := U[J] + LT × RL[J];
DERIVATIVE(T + MT, RL);
if I = 0 ∨ I = N-1 then
begin THT := if I = 0 then THETA0 × H else THETANM1 × H;
ELMVEC(M0, M, 0, U, RL, THT)
end;
if I < N-1 then goto NEXTTERM;
T := T + H
end DIFFERENCE SCHEME;
N := R + L; FIRST := true; B0 := -1; BETAR := BETA[R]⭡(1/R);
LAST := false; EPS := 2⭡(-48); PI := PHI0 := PHIL := 4 × ARCTAN(1);
NEXTLEVEL:
STEPSIZE;
if CHANGE then COEFFICIENT;
K := K + 1;
DIFFERENCE SCHEME;
OUTPUT;
if ¬LAST then goto NEXTLEVEL;
ENDOFEFRK:
end EXPONENTIALLY FITTED RUNGE KUTTA;
comment ================== 33160 ================= ;
procedure EFSIRK(X, XE, M, Y, DELTA, DERIVATIVE, JACOBIAN, J,
N, AETA, RETA, HMIN, HMAX, LINEAR, OUTPUT);
value M; integer M, N;
real X, XE, DELTA, AETA, RETA, HMIN, HMAX;
procedure DERIVATIVE, JACOBIAN, OUTPUT;
Boolean LINEAR;
array Y, J;
begin integer K, L;
real STEP, H, MU0, MU1, MU2, THETA0, THETA1, NU1, NU2,
NU3, YK, FK, C1, C2, D;
array F, K0, LABDA[1 : M], J1[1 : M, 1 : M], AUX[1 : 7];
integer array RI, CI[1 : M];
Boolean LIN;
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
real procedure MATMAT(L, U, I, J, A, B); code 34013;
real procedure MATVEC(L, U, I, A, B); code 34011;
procedure GSSELM(A, N, AUX, RI, CI); code 34231;
procedure SOLELM(A, N, RI, CI, B); code 34061;
real procedure STEPSIZE;
begin real DISCR, ETA, S;
if LINEAR then S := H := HMAX else
if N = 1 ∨ HMIN = HMAX then S := H := HMIN else
begin ETA := AETA + RETA × SQRT(VECVEC(1, M, 0, Y, Y));
C1 := NU3 × STEP; for K := 1 step 1 until M do
LABDA[K] := LABDA[K] + C1 × F[K] - Y[K];
DISCR := SQRT(VECVEC(1, M, 0, LABDA, LABDA));
S := H := (ETA / (0.75 × (ETA + DISCR)) + 0.33) × H;
if H < HMIN then S := H := HMIN else
if H > HMAX then S := H := HMAX
end;
if X + S > XE then S := XE - X;
LIN := STEP = S ∧ LINEAR; STEPSIZE := S
end STEPSIZE;
procedure COEFFICIENT;
begin real Z1, E, ALPHA1, A, B;
own real Z2;
Z1 := STEP × DELTA; if N = 1 then Z2 := Z1 + Z1;
if ABS(Z2 - Z1) > 10-6 × ABS(Z1) ∨ Z2 > - 1 then
begin A := Z1 × Z1 + 12; B := 6 × Z1;
if ABS(Z1) < 0.1 then
ALPHA1 := (Z1 × Z1 / 140 - 1) × Z1 / 30 else
if Z1 < - 1014 then ALPHA1 := 1 / 3 else
if Z1 < - 33 then
ALPHA1 := (A + B) / (3 × Z1 × (2 + Z1)) else
begin E := if Z1 < 230 then EXP(Z1) else 10100;
ALPHA1 := ((A - B) × E - A - B) /
(((2 - Z1) × E - 2 - Z1) × 3 × Z1)
end;
MU2 := (1 / 3 + ALPHA1) × 0.25;
MU1 := - (1 + ALPHA1) × 0.5;
MU0 := (6 × MU1 + 2) / 9; THETA0 := 0.25;
THETA1 := 0.75; A := 3 × ALPHA1;
NU3 := (1 + A) / (5 - A) × 0.5; A := NU3 + NU3;
NU1 := 0.5 - A; NU2 := (1 + A) × 0.75;
Z2 := Z1
end
end COEFFICIENT;
procedure DIFFERENCE SCHEME;
begin DERIVATIVE(F); STEP := STEPSIZE;
if ¬LINEAR ∨ N = 1 then JACOBIAN(J, Y);
if ¬LIN then
begin COEFFICIENT;
C1 := STEP × MU1; D := STEP × STEP × MU2;
for K := 1 step 1 until M do
begin for L := 1 step 1 until M do
J1[K, L] := D × MATMAT(1, M, K, L, J, J) +
C1 × J[K, L];
J1[K, K] := J1[K, K] + 1
end;
GSSELM(J1, M, AUX, RI, CI)
end;
C1 := STEP × STEP × MU0; D := STEP × 2 / 3;
for K := 1 step 1 until M do
begin K0[K] := FK := F[K];
LABDA[K] := D × FK + C1 × MATVEC(1, M, K, J, F)
end;
SOLELM(J1, M, RI, CI, LABDA);
for K := 1 step 1 until M do F[K] := Y[K] + LABDA[K];
DERIVATIVE(F);
C1 := THETA0 × STEP; C2 := THETA1 × STEP; D := NU1 × STEP;
for K := 1 step 1 until M do
begin YK := Y[K]; FK := F[K];
LABDA[K] := YK + D × FK + NU2 × LABDA[K];
Y[K] := F[K] := YK + C1 × K0[K] + C2 × FK
end
end DIFFERENCE SCHEME;
AUX[2] := 10-14; AUX[4] := 8;
for K := 1 step 1 until M do F[K] := Y[K];
N := 0; OUTPUT; STEP := 0;
NEXT STEP: N := N + 1;
DIFFERENCE SCHEME; X := X + STEP; OUTPUT;
if X < XE then goto NEXT STEP
end EFSIRK;
comment ================== 33120 ================= ;
procedure EFERK(X, XE, M, Y, SIGMA, PHI, DERIVATIVE, J, JACOBIAN,
K, L, AUT, AETA, RETA, HMIN, HMAX, LINEAR, OUTPUT);
value L; integer M, K, L;
real X, XE, SIGMA, PHI, AETA, RETA, HMIN, HMAX; array Y, J;
Boolean AUT, LINEAR; procedure DERIVATIVE, JACOBIAN, OUTPUT;
begin integer M1, I;
real H, B, B0, PHI0, COSPHI, SINPHI, ETA, DISCR, FAC, PI;
Boolean CHANGE, LAST;
integer array P[1:L];
real array BETA, BETHA[0:L], BETAC[0:L + 3], K0, D, D1, D2[1:M],
A[1:L, 1:L], AUX[1:3];
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
real procedure MATVEC(L, U, I, A, B); code 34011;
procedure DEC(A, N, AUX, P); code 34300;
procedure SOL(A, N, P, B); code 34051;
real procedure SUM(I, L, U, T); value L, U; integer I, L, U;
real T;
begin real S; S := 0;
for I := L step 1 until U do S := S + T;
SUM := S
end;
procedure FORMBETA;
if L = 1 then
begin BETHA[1] := (.5-(1-(1-EXP(-B))/B)/B)/B;
BETA[1] := (1/6-BETHA[1])/B
end else
if L = 2 then
begin real E, EMIN1; E := EXP(-B); EMIN1 := E-1;
BETHA[1] := (1-(3 + E + 4 × EMIN1/B)/B)/B;
BETHA[2] := (.5-(2 + E + 3 × EMIN1/B)/B)/B/B;
BETA[2] := (1/6-BETHA[1])/B/B;
BETA[1] := (1/3-(1.5-(4 + E + 5 × EMIN1/B)/B)/B)/B
end else
begin real B0, B1, B2, A0, A1, A2, A3, C, D;
BETAC[L-1] := C := D := EXP(-B)/FAC;
for I := L-1 step -1 until 1 do
begin C := I × B × C/(L-I); BETAC[I-1] := D := D × I + C end;
B2 := .5-BETAC[2];
B1 := (1-BETAC[1]) × (L + 1)/B;
B0 := (1-BETAC[0]) × (L + 2) × (L + 1) × .5/B/B;
A3 := 1/6-BETAC[3];
A2 := B2 × (L + 1)/B;
A1 := B1 × (L + 2) × .5/B;
A0 := B0 × (L + 3)/3/B;
D := L/B;
for I := 1 step 1 until L do
begin BETA[I] := (A3/I-A2/(I + 1) + A1/(I + 2)-A0/(I + 3)) × D + BETAC[I + 3];
BETHA[I] := (B2/I-B1/(I + 1) + B0/(I + 2)) × D + BETAC[I + 2];
D := D × (L-I)/I/B;
end
end FORMBETA;
procedure SOLUTIONOFCOMPLEXEQUATIONS;
if L = 2 then
begin real COS2PHI, COSA, SINA, E, ZI;
PHI0 := PHI; COSPHI := COS(PHI0); SINPHI := SIN(PHI0);
E := EXP(B × COSPHI); ZI := B × SINPHI-3 × PHI0;
SINA := (if ABS(SINPHI) < 10-6 then -E × (B + 3)
else E × SIN(ZI)/SINPHI);
COS2PHI := 2 × COSPHI × COSPHI-1;
BETHA[2] := (.5 + (2 × COSPHI + (1 + 2 × COS2PHI + SINA)/B)/B)/B/B;
SINA := (if ABS(SINPHI) < 10-6 then E × (B + 4)
else SINA × COSPHI-E × COS(ZI));
BETHA[1] := -(COSPHI + (1 + 2 × COS2PHI + (4 × COSPHI × COS2PHI + SINA)
/B)/B)/B;
BETA[1] := BETHA[2] + 2 × COSPHI × (BETHA[1]-1/6)/B;
BETA[2] := (1/6-BETHA[1])/B/B
end else
begin integer J, C1;
real C2, E, ZI, COSIPHI, SINIPHI, COSPHIL;
real array D[1:L];
procedure ELEMENTS OF MATRIX;
begin PHI0 := PHI;
COSPHI := COS(PHI0); SINPHI := SIN(PHI0);
COSIPHI := 1; SINIPHI := 0;
for I := 0 step 1 until L-1 do
begin C1 := 4 + I; C2 := 1;
for J := L-1 step -2 until 1 do
begin A[J, L-I] := C2 × COSIPHI;
A[J + 1, L-I] := C2 × SINIPHI;
C2 := C2 × C1; C1 := C1-1
end;
COSPHIL := COSIPHI × COSPHI-SINIPHI × SINPHI;
SINIPHI := COSIPHI × SINPHI + SINIPHI × COSPHI;
COSIPHI := COSPHIL
end;
AUX[2] := 0; DEC(A, L, AUX, P)
end EL OF MAT;
procedure RIGHT HAND SIDE;
begin E := EXP(B × COSPHI);
ZI := B × SINPHI-4 × PHI0;
COSIPHI := E × COS(ZI); SINIPHI := E × SIN(ZI);
ZI := 1/B/B/B;
for J := L step -2 until 2 do
begin D[J] := ZI × SINIPHI;
D[J-1] := ZI × COSIPHI;
COSPHIL := COSIPHI × COSPHI-SINIPHI × SINPHI;
SINIPHI := COSIPHI × SINPHI + SINIPHI × COSPHI;
COSIPHI := COSPHIL; ZI := ZI × B
end;
SINIPHI := 2 × SINPHI × COSPHI;
COSIPHI := 2 × COSPHI × COSPHI-1;
COSPHIL := COSPHI × (2 × COSIPHI-1);
D[L] := D[L] + SINPHI × (1/6 + (COSPHI + (1 + 2 × COSIPHI × (1 + 2 × COSPHI/B))
/B)/B);
D[L-1] := D[L-1]-COSPHI/6-(.5 × COSIPHI + (COSPHIL + (2 × COSIPHI ×
COSIPHI-1)/B)/B)/B;
D[L-2] := D[L-2] + SINPHI × (.5 + (2 × COSPHI + (2 × COSIPHI + 1)/B)/B);
D[L-3] := D[L-3]-.5 × COSPHI-(COSIPHI + COSPHIL/B)/B;
if L < 5 then goto END;
D[L-4] := D[L-4] + SINPHI + SINIPHI/B;
D[L-5] := D[L-5]-COSPHI-COSIPHI/B;
if L < 7 then goto END;
D[L-6] := D[L-6] + SINPHI;
D[L-7] := D[L-7]-COSPHI;
END:
end RHS;
if PHI0 ≠ PHI then ELEMENTS OF MATRIX;
RIGHT HAND SIDE;
SOL(A, L, P, D);
ZI := 1/B;
for I := 1 step 1 until L do
begin BETA[I] := D[L + 1-I] × ZI;
BETHA[I] := (I + 3) × BETA[I];
ZI := ZI/B
end
end SOLOFEQCOM;
procedure COEFFICIENT;
begin B0 := B := ABS(H × SIGMA);
if B ≥ .1 then
begin if PHI ≠ PI ∧ L = 2 ∨ ABS(PHI-PI) > .01 then
SOLUTION OF COMPLEX EQUATIONS else FORMBETA
end else
begin for I := 1 step 1 until L do
begin BETHA[I] := BETA[I-1];
BETA[I] := BETA[I-1]/(I + 3);
end
end
end COEFFICIENT;
procedure LOCAL ERROR BOUND;
ETA := AETA + RETA × SQRT(VECVEC(1, M1, 0, Y, Y));
procedure STEPSIZE;
begin LOCAL ERROR BOUND;
if K = 0 then
begin DISCR := SQRT(VECVEC(1, M1, 0, D, D)); H := ETA/DISCR
end else
begin DISCR := H × SQRT(SUM(I, 1, M1, (D[I]-D2[I])⭡2))/ETA;
H := H × (if LINEAR then 4/(4 + DISCR) + .5
else 4/(3 + DISCR) + 1/3)
end;
if H < HMIN then H := HMIN;
if H > HMAX then H := HMAX;
B := ABS(H × SIGMA);
CHANGE := ABS(1-B/B0) > .05 ∨ PHI ≠ PHI0;
if 1.1 × H ≥ XE-X then
begin CHANGE := LAST := true; H := XE-X end;
if ¬CHANGE then H := H × B0/B
end STEPSIZE;
procedure DIFFERENCE SCHEME;
begin integer K;
real BETAI, BETHAI;
if M1 < M then
begin D2[M] := 1; K0[M] := Y[M] + 2 × H/3; Y[M] := Y[M] + .25 × H end;
for K := 1 step 1 until M1 do
begin K0[K] := Y[K] + 2 × H/3 × D[K];
Y[K] := Y[K] + .25 × H × D[K];
D1[K] := H × MATVEC(1, M, K, J, D);
D2[K] := D1[K] + D[K]
end;
for I := 0 step 1 until L do
begin BETAI := 4 × BETA[I]/3; BETHAI := BETHA[I];
for K := 1 step 1 until M1 do D[K] := H × D1[K];
for K := 1 step 1 until M1 do
begin K0[K] := K0[K] + BETAI × D[K];
D1[K] := MATVEC(1, M1, K, J, D);
D2[K] := D2[K] + BETHAI × D1[K]
end
end;
DERIVATIVE(K0);
for K := 1 step 1 until M do Y[K] := Y[K] + .75 × H × K0[K]
end DIFF SCHEME;
B0 := PHI0 := -1; PI := 4 × ARCTAN(1);
BETAC[L] := BETAC[L + 1] := BETAC[L + 2] := BETAC[L + 3] := 0;
BETA[0] := 1/6; BETHA[0] := .5;
FAC := 1; for I := 2 step 1 until L-1 do FAC := I × FAC;
M1 := if AUT then M else M-1;
K := 0; LAST := false;
NEXT LEVEL:
for I := 1 step 1 until M do D[I] := Y[I];
DERIVATIVE(D);
if ¬LINEAR ∨ K = 0 then JACOBIAN(J, Y);
STEPSIZE;
if CHANGE then COEFFICIENT;
OUTPUT;
DIFFERENCE SCHEME;
K := K + 1;
X := X + H;
if ¬LAST then goto NEXT LEVEL;
END OF EFERK: OUTPUT;
end EFERK;
comment ================== 33131 ================= ;
procedure LINIGER2(X, XE, M, Y, SIGMA1, SIGMA2, F, EVALUATE, J,
JACOBIAN, K, ITMAX, STEP, AETA, RETA, OUTPUT);
integer M, K, ITMAX;
real X, XE, SIGMA1, SIGMA2, STEP, AETA, RETA;
array Y, J;
Boolean procedure EVALUATE;
real procedure F;
procedure JACOBIAN, OUTPUT;
begin integer I;
real H, HL, B1, B2, P, Q, C0, C1, C2, C3, C4;
Boolean LAST;
integer array PI[1:M];
real array DY, YL, FL[1:M], A[1:M, 1:M], AUX[1:3];
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
real procedure MATVEC(L, U, I, A, B); code 34011;
real procedure MATMAT(L, U, I, J, A, B); code 34013;
procedure DEC(A, N, AUX, P); code 34300;
procedure SOL(A, N, P, B); code 34051;
procedure STEPSIZE;
begin H := STEP;
if 1.1 × H ≥ XE-X then
begin LAST := true; H := XE-X; X := XE
end else X := X + H
end STEPSIZE;
procedure COEFFICIENT;
begin real R1, R2, EX, ZETA, ETA, SINL, COSL, SINH, COSH, D;
real procedure R(X); value X; real X;
if X > 40 then R := X/(X-2) else
begin EX := EXP(-X); R := X × (1-EX)/(X-2 + (X + 2) × EX) end;
B1 := H × SIGMA1;
B2 := H × SIGMA2;
if B1 < .1 then begin P := 0; Q := 1/3; goto OUT end;
if B2 < 0 then goto COMPLEX;
if B1 < 1 ∨ B2 < .1 then goto THIRDORDER;
if ABS(B1-B2) < B1 × B1 × 10-6 then goto DOUBLEFIT;
R1 := R(B1) × B1; R2 := R(B2) × B2;
D := B2 × R1-B1 × R2;
P := 2 × (R2-R1)/D;
Q := 2 × (B2-B1)/D;
goto OUT;
THIRDORDER: Q := 1/3;
P := R(B1)/3-2/B1;
goto OUT;
DOUBLEFIT: B1 := .5 × (B1 + B2);
R1 := R(B1);
if B1 > 40 then EX := 0;
R2 := B1/(1-EX); R2 := 1-EX × R2 × R2;
Q := 1/(R1 × R1 × R2);
P := R1 × Q-2/B1;
goto OUT;
COMPLEX: ETA := ABS(B1 × SIN(SIGMA2));
ZETA := ABS(B1 × COS(SIGMA2));
if ETA < B1 × B1 × 10-6 then
begin B1 := B2 := ZETA; goto DOUBLEFIT end;
if ZETA > 40 then
begin P := 1-4 × ZETA/B1/B1; Q := 4 × (1-ZETA)/B1/B1 + 1 end else
begin EX := EXP(ZETA);
SINL := SIN(ETA); COSL := COS(ETA);
SINH := .5 × (EX-1/EX); COSH := .5 × (EX + 1/EX);
D := ETA × (COSH-COSL)-.5 × B1 × B1 × SINL;
P := (ZETA × SINL + ETA × SINH-4 × ZETA × ETA/B1/B1 × (COSH-COSL))/D;
Q := ETA × ((COSH-COSL-ZETA × SINH-ETA × SINL) × 4/B1/B1 + COSH + COSL)/D
end;
OUT: C0 := .25 × H × H × (P + Q);
C1 := .5 × H × (1 + P);
C2 := H-C1;
C3 := .25 × H × H × (Q-P);
C4 := .5 × H × P;
ELEMENTS OF MATRIX
end COEFFICIENT;
procedure ELEMENTS OF MATRIX;
begin integer K;
for I := 1 step 1 until M do
begin for K := 1 step 1 until M do
A[I, K] := C0 × MATMAT(1, M, I, K, J, J)-C1 × J[I, K];
A[I, I] := A[I, I] + 1
end;
AUX[2] := 0; DEC(A, M, AUX, PI)
end ELOFMAT;
procedure NEWTON ITERATION;
begin integer ITNUM; real JFL, ETA, DISCR;
ITNUM := 0;
NEXT: ITNUM := ITNUM + 1;
if EVALUATE(ITNUM) then
begin JACOBIAN(J, Y); COEFFICIENT end
else if ITNUM = 1 ∧ H ≠ HL then COEFFICIENT;
for I := 1 step 1 until M do FL[I] := F(I);
if ITNUM = 1 then
begin for I := 1 step 1 until M do
begin JFL := MATVEC(1, M, I, J, FL);
DY[I] := H × (FL[I]-C4 × JFL);
YL[I] := Y[I] + C2 × FL[I] + C3 × JFL
end
end else
for I := 1 step 1 until M do
DY[I] := YL[I]-Y[I] + C1 × FL[I]-C0 × MATVEC(1, M, I, J, FL);
SOL(A, M, PI, DY);
for I := 1 step 1 until M do Y[I] := Y[I] + DY[I];
if ITNUM < ITMAX then
begin ETA := SQRT(VECVEC(1, M, 0, Y, Y)) × RETA + AETA;
DISCR := SQRT(VECVEC(1, M, 0, DY, DY));
if ETA < DISCR then goto NEXT
end
end NEWTON;
LAST := false; K := 0; HL := 0;
NEXT LEVEL:
K := K + 1;
STEPSIZE;
NEWTON ITERATION;
HL := H;
OUTPUT;
if ¬LAST then goto NEXT LEVEL
end LINIGER2;
comment ================== 33040 ================= ;
procedure MODIFIED TAYLOR(T, TE, M0, M, U, SIGMA, TAUMIN, I, DERIVATIVE, K,
DATA, ALFA, NORM, AETA, RETA, ETA, RHO, OUT);
integer M0, M, I, K, NORM;
real T, TE, SIGMA, TAUMIN, ALFA, AETA, RETA, ETA, RHO;
array U, DATA;
procedure DERIVATIVE, OUT;
begin I := 0;
begin integer N, P, Q;
own real EC0, EC1, EC2, TAU0, TAU1, TAU2, TAUS, T2;
real T0, TAU, TAUI, TAUEC, ECL, BETAN, GAMMA;
real array C[M0:M], BETA, BETHA[1:DATA[-2]];
Boolean START, STEP1, LAST;
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
procedure COEFFICIENT;
begin integer J; real IFAC;
IFAC := 1; GAMMA := .5; N := DATA[-2]; P := DATA[-1];
BETAN := DATA[0]; Q := if P < N then P + 1 else N;
for J := 1 step 1 until N do
begin BETA[J] := DATA[J]; IFAC := IFAC/J;
BETHA[J] := IFAC-BETA[J]
end;
if P = N then BETHA[N] := IFAC
end;
real procedure NORMFUNCTION(NORM, W);
integer NORM; array W;
begin integer J; real S, X;
S := 0;
if NORM = 1 then
begin for J := M0 step 1 until M do
begin X := ABS(W[J]); if X > S then S := X end
end else
S := SQRT(VECVEC(M0, M, 0, W, W));
NORMFUNCTION := S
end;
procedure LOCAL ERROR BOUND;
ETA := AETA + RETA × NORMFUNCTION(NORM, U);
procedure LOCAL ERROR CONSTRUCTION(I); integer I;
begin if I = P then begin ECL := 0; TAUEC := 1 end;
if I > P + 1 then TAUEC := TAUEC × TAU;
ECL := ECL + ABS(BETHA[I]) × TAUEC × NORMFUNCTION(NORM, C);
if I = N then
begin EC0 := EC1; EC1 := EC2; EC2 := ECL;
RHO := ECL × TAU⭡Q
end
end;
procedure STEPSIZE;
begin real TAUACC, TAUSTAB, AA, BB, CC, EC;
LOCAL ERROR BOUND;
if ETA > 0 then
begin if START then
begin if K = 0 then
begin integer J;
for J := M0 step 1 until M do C[J] := U[J];
I := 1; DERIVATIVE(I, C);
TAUACC := ETA/NORMFUNCTION(NORM, C);
STEP1 := true
end else
if STEP1 then
begin TAUACC := (ETA/RHO)⭡(1/Q) × TAU2;
if TAUACC > 10 × TAU2 then
TAUACC := 10 × TAU2 else STEP1 := false
end else
begin BB := (EC2-EC1)/TAU1; CC := EC2-BB × T2;
EC := BB × T + CC;
TAUACC := if EC < 0 then TAU2 else
(ETA/EC)⭡(1/Q);
START := false
end
end else
begin AA := ((EC0-EC1)/TAU0 + (EC2-EC1)/TAU1)/
(TAU1 + TAU0);
BB := (EC2-EC1)/TAU1-AA × (2 × T2-TAU1);
CC := EC2-T2 × (BB + AA × T2); EC := CC + T × (BB + T × AA);
TAUACC := if EC < 0 then TAUS
else (ETA/EC)⭡(1/Q);
if TAUACC > ALFA × TAUS then TAUACC := ALFA × TAUS;
if TAUACC < GAMMA × TAUS then TAUACC := GAMMA × TAUS;
end
end else TAUACC := TE-T;
if TAUACC < TAUMIN then TAUACC := TAUMIN;
TAUSTAB := BETAN/SIGMA;
if TAUSTAB < 10-12 × (T-T0) then
begin OUT; goto END OF MODIFIED TAYLOR end;
TAU := if TAUACC > TAUSTAB then TAUSTAB else TAUACC;
TAUS := TAU; if TAU ≥ TE-T then
begin TAU := TE-T; LAST := true end;
TAU0 := TAU1; TAU1 := TAU2; TAU2 := TAU
end;
procedure DIFFERENCE SCHEME;
begin integer J; real B;
for J := M0 step 1 until M do C[J] := U[J]; TAUI := 1;
NEXT TERM:
I := I + 1; DERIVATIVE(I, C); TAUI := TAUI × TAU;
B := BETA[I] × TAUI;
if ETA > 0 ∧ I ≥ P then LOCAL ERROR CONSTRUCTION(I);
for J := M0 step 1 until M do U[J] := U[J] + B × C[J];
if I < N then goto NEXT TERM;
T2 := T; if LAST then
begin LAST := false; T := TE end
else T := T + TAU
end;
START := K = 0; T0 := T;
COEFFICIENT; LAST := false;
NEXT LEVEL:
STEPSIZE; K := K + 1; I := 0; DIFFERENCE SCHEME; OUT;
if T ≠ TE then goto NEXT LEVEL
end;
END OF MODIFIED TAYLOR:
end MODIFIED TAYLOR;
comment ================== 33050 ================= ;
procedure EXPONENTIALLY FITTED TAYLOR(T, TE, M0, M, U, SIGMA, PHI, DIAMETER,
DERIVATIVE, I, K, ALFA, NORM, AETA, RETA, ETA, RHO, HMIN, HSTART, OUTPUT);
integer M0, M, I, K, NORM;
real T, TE, SIGMA, PHI, DIAMETER, ALFA, AETA, RETA, ETA, RHO, HMIN, HSTART;
array U;
procedure DERIVATIVE, OUTPUT;
begin integer KL;
real Q, EC0, EC1, EC2, H, HI, H0, H1, H2, BETAN, T2, SIGMAL, PHIL;
real array C, RO[M0:M], BETA, BETHA[1:3];
Boolean LAST, START;
procedure INIVEC(L, U, A, X); code 31010;
procedure DUPVEC(L, U, SHIFT, A, B); code 31030;
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
procedure ELMVEC(L, U, SHIFT, A, B, X); code 34020;
Boolean procedure ZEROIN(X, Y, FX, EPS); code 34150;
procedure COEFFICIENT;
begin real B, B1, B2, BB, E, BETA2, BETA3;
B := H × SIGMAL; B1 := B × COS(PHIL); BB := B × B;
if ABS(B) < 10-3 then
begin BETA2 := .5-BB/24;
BETA3 := 1/6 + B1/12;
BETHA[3] := .5 + B1/3
end else
if B1 < -40 then
begin BETA2 := (-2 × B1-4 × B1 × B1/BB + 1)/BB;
BETA3 := (1 + 2 × B1/BB)/BB;
BETHA[3] := 1/BB
end else
begin E := EXP(B1)/BB; B2 := B × SIN(PHIL);
BETA2 := (-2 × B1-4 × B1 × B1/BB + 1)/BB;
BETA3 := (1 + 2 × B1/BB)/BB;
if ABS(B2/B) < 10-5 then
begin BETA2 := BETA2-E × (B1-3);
BETA3 := BETA3 + E × (B1-2)/B1;
BETHA[3] := 1/BB + E × (B1-1)
end else
begin BETA2 := BETA2-E × SIN(B2-3 × PHIL)/B2 × B;
BETA3 := BETA3 + E × SIN(B2-2 × PHIL)/B2;
BETHA[3] := 1/BB + E × SIN(B2-PHIL)/B2 × B;
end
end;
BETA[1] := BETHA[1] := 1;
BETA[2] := BETA2; BETA[3] := BETA3;
BETHA[2] := 1-BB × BETA3; B := ABS(B);
Q := if B < 1.5 then 4-2 × B/3 else if B < 6 then (30-2 × B)/9
else 2;
end;
real procedure NORMFUNCTION(NORM, W);
integer NORM; array W;
begin integer J; real S, X;
S := 0;
if NORM = 1 then
begin for J := M0 step 1 until M do
begin X := ABS(W[J]); if X > S then S := X end
end else
S := SQRT(VECVEC(M0, M, 0, W, W));
NORMFUNCTION := S;
end;
procedure LOCAL ERROR BOUND;
ETA := AETA + RETA × NORMFUNCTION(NORM, U);
procedure LOCAL ERROR CONSTRUCTION(I); integer I;
begin if I = 1 then INIVEC(M0, M, RO, 0);
if I < 4 then ELMVEC(M0, M, 0, RO, C, BETHA[I] × HI);
if I = 4 then
begin ELMVEC(M0, M, 0, RO, C, -H);
RHO := NORMFUNCTION(NORM, RO);
EC0 := EC1; EC1 := EC2; EC2 := RHO/H⭡Q;
end
end;
procedure STEPSIZE;
begin real HACC, HSTAB, HCR, HMAX, A, B, C;
if ¬START then LOCAL ERROR BOUND;
if START then
begin H1 := H2 := HACC := HSTART;
EC2 := EC1 := 1; KL := 1; START := false
end else
if KL < 3 then
begin HACC := (ETA/RHO)⭡(1/Q) × H2;
if HACC > 10 × H2 then HACC := 10 × H2 else KL := KL + 1
end else
begin A := (H0 × (EC2-EC1)-H1 × (EC1-EC0))/(H2 × H0-H1 × H1);
H := H2 × (if ETA < RHO then (ETA/RHO)⭡(1/Q) else ALFA);
if A > 0 then
begin B := (EC2-EC1-A × (H2-H1))/H1;
C := EC2-A × H2-B × T2; HACC := 0; HMAX := H;
if ¬ZEROIN(HACC, H, HACC⭡Q × (A × HACC + B × T + C)-ETA,
10-3 × H2) then HACC := HMAX
end else HACC := H;
if HACC < .5 × H2 then HACC := .5 × H2;
end;
if HACC < HMIN then HACC := HMIN; H := HACC;
if H × SIGMAL > 1 then
begin A := ABS(DIAMETER/SIGMAL + 10-14)/2; B := 2 × ABS(SIN(PHIL));
BETAN := (if A > B then 1/A else 1/B)/A;
HSTAB := ABS(BETAN/SIGMAL);
if HSTAB < 10-14 × T then goto ENDOFEFT;
if H > HSTAB then H := HSTAB
end;
HCR := H2 × H2/H1;
if KL > 2 ∧ ABS(H-HCR) < 10-6 × HCR then
H := if H < HCR then HCR × (1-10-7) else HCR × (1 + 10-7);
if T + H > TE then
begin LAST := true; HSTART := H; H := TE-T end;
H0 := H1; H1 := H2; H2 := H;
end;
procedure DIFFERENCE SCHEME;
begin HI := 1; SIGMAL := SIGMA; PHIL := PHI;
STEPSIZE;
COEFFICIENT;
for I := 1, 2, 3 do
begin HI := HI × H;
if I > 1 then DERIVATIVE(I, C);
LOCALERRORCONSTRUCTION(I);
ELMVEC(M0, M, 0, U, C, BETA[I] × HI)
end;
T2 := T; K := K + 1;
if LAST then
begin LAST := false; T := TE; START := true
end else T := T + H;
DUPVEC(M0, M, 0, C, U);
DERIVATIVE(1, C);
LOCALERRORCONSTRUCTION(4);
OUTPUT;
end;
START := true; LAST := false;
DUPVEC(M0, M, 0, C, U);
DERIVATIVE(1, C);
if K = 0 then
begin LOCAL ERROR BOUND; HSTART := ETA/NORMFUNCTION(NORM, C)
end;
NEXT LEVEL:
DIFFERENCE SCHEME;
if T ≠ TE then goto NEXT LEVEL;
ENDOFEFT:
end EXPONENTIAL FITTED TAYLOR;
comment ================== 33012 ================= ;
procedure RK2(X, A, B, Y, YA, Z, ZA, FXYZ, E, D, FI);
value B, FI; real X, A, B, Y, YA, Z, ZA, FXYZ; Boolean FI;
array E, D;
begin real E1, E2, E3, E4, XL, YL, ZL, H, INT, HMIN, HL,
ABSH, K0, K1, K2, K3, K4, K5, DISCRY, DISCRZ, TOLY,
TOLZ, MU, MU1, FHY, FHZ;
Boolean LAST, FIRST, REJECT;
if FI then
begin D[3] := A; D[4] := YA; D[5] := ZA end;
D[1] := 0; XL := D[3]; YL := D[4]; ZL := D[5];
if FI then D[2] := B - D[3]; ABSH := H := ABS(D[2]);
if B - XL < 0 then H := - H; INT := ABS(B - XL);
HMIN := INT × E[1] + E[2]; HL := INT × E[3] + E[4];
if HL < HMIN then HMIN := HL; E1 := E[1] / INT;
E2 := E[2] / INT; E3 := E[3] / INT; E4 := E[4] / INT;
FIRST := true; if FI then
begin LAST := true; goto STEP end;
TEST: ABSH := ABS(H); if ABSH < HMIN then
begin H := if H > 0 then HMIN else - HMIN; ABSH := HMIN
end;
if H ≥ B - XL equiv H ≥ 0 then
begin D[2] := H; LAST := true; H := B - XL;
ABSH := ABS(H)
end
else LAST := false;
STEP: X := XL; Y := YL; Z := ZL; K0 := FXYZ × H;
X := XL + H / 4.5;
Y := YL + (ZL × 18 + K0 × 2) / 81 × H;
Z := ZL + K0 / 4.5 ; K1 := FXYZ × H; X := XL + H / 3;
Y := YL + (ZL × 6 + K0) / 18 × H;
Z := ZL + (K0 + K1 × 3) / 12; K2 := FXYZ × H;
X := XL + H × .5;
Y := YL + (ZL × 8 + K0 + K2) / 16 × H;
Z := ZL + (K0 + K2 × 3) / 8; K3 := FXYZ × H;
X := XL + H × .8;
Y := YL + (ZL × 100 + K0 × 12 + K3 × 28) / 125 × H;
Z := ZL + (K0 × 53 - K1 × 135 + K2 × 126 + K3 × 56)
/ 125; K4 := FXYZ × H; X := if LAST then B else XL + H;
Y := YL + (ZL × 336 + K0 × 21 + K2 × 92 + K4 × 55) /
336 × H;
Z := ZL + (K0 × 133 - K1 × 378 + K2 × 276 + K3 × 112
+ K4 × 25) / 168; K5 := FXYZ × H;
DISCRY := ABS(( - K0 × 21 + K2 × 108 - K3 × 112 + K4
× 25) / 56 × H);
DISCRZ := ABS(K0 × 21 - K2 × 162 + K3 × 224 - K4 ×
125 + K5 × 42) / 14;
TOLY := ABSH × (ABS(ZL) × E1 + E2);
TOLZ := ABS(K0) × E3 + ABSH × E4;
REJECT := DISCRY > TOLY ∨ DISCRZ > TOLZ;
FHY := DISCRY / TOLY; FHZ := DISCRZ / TOLZ;
if FHZ > FHY then FHY := FHZ;
MU := 1 / (1 + FHY) + .45; if REJECT then
begin if ABSH ≤ HMIN then
begin D[1] := D[1] + 1; Y := YL; Z := ZL;
FIRST := true; goto NEXT
end;
H := MU × H; goto TEST
end;
if FIRST then
begin FIRST := false; HL := H; H := MU × H; goto ACC
end;
FHY := MU × H / HL + MU - MU1; HL := H; H := FHY × H;
ACC: MU1 := MU;
Y := YL + (ZL × 56 + K0 × 7 + K2 × 36 - K4 × 15) / 56
× HL;
Z := ZL + ( - K0 × 63 + K1 × 189 - K2 × 36 - K3 × 112
+ K4 × 50) / 28; K5 := FXYZ × HL;
Y := YL + (ZL × 336 + K0 × 35 + K2 × 108 + K4 × 25)
/ 336 × HL;
Z := ZL + (K0 × 35 + K2 × 162 + K4 × 125 + K5 × 14)
/ 336;
NEXT: if B ≠ X then
begin XL := X; YL := Y; ZL := Z; goto TEST end;
if ¬LAST then D[2] := H; D[3] := X; D[4] := Y; D[5] := Z
end RK2;
comment ================== 33013 ================= ;
procedure RK2N(X, A, B, Y, YA, Z, ZA, FXYZJ, J, E, D,
FI, N); value B, FI, N; integer J, N; real X, A, B, FXYZJ;
Boolean FI; array Y, YA, Z, ZA, E, D;
begin integer JJ;
real XL, H, INT, HMIN, HL, ABSH, FHM, DISCRY, DISCRZ,
TOLY, TOLZ, MU, MU1, FHY, FHZ;
Boolean LAST, FIRST, REJECT;
array YL, ZL, K0, K1, K2, K3, K4, K5[1:N], EE[1:4 ×
N];
if FI then
begin D[3] := A;
for JJ := 1 step 1 until N do
begin D[JJ + 3] := YA[JJ]; D[N + JJ + 3] := ZA[JJ]
end
end;
D[1] := 0; XL := D[3];
for JJ := 1 step 1 until N do
begin YL[JJ] := D[JJ + 3]; ZL[JJ] := D[N + JJ + 3] end;
if FI then D[2] := B - D[3]; ABSH := H := ABS(D[2]);
if B - XL < 0 then H := - H; INT := ABS(B - XL);
HMIN := INT × E[1] + E[2];
for JJ := 2 step 1 until 2 × N do
begin HL := INT × E[2 × JJ - 1] + E[2 × JJ];
if HL < HMIN then HMIN := HL
end;
for JJ := 1 step 1 until 4 × N do EE[JJ] := E[JJ] / INT;
FIRST := true; if FI then
begin LAST := true; goto STEP end;
TEST: ABSH := ABS(H); if ABSH < HMIN then
begin H := if H > 0 then HMIN else - HMIN;
ABSH := ABS(H)
end;
if H ≥ B - XL equiv H ≥ 0 then
begin D[2] := H; LAST := true; H := B - XL;
ABSH := ABS(H)
end
else LAST := false;
STEP: X := XL;
for JJ := 1 step 1 until N do
begin Y[JJ] := YL[JJ]; Z[JJ] := ZL[JJ] end;
for J := 1 step 1 until N do K0[J] := FXYZJ × H;
X := XL + H / 4.5;
for JJ := 1 step 1 until N do
begin Y[JJ] := YL[JJ] + (ZL[JJ] × 18 + K0[JJ] × 2) /
81 × H; Z[JJ] := ZL[JJ] + K0[JJ] / 4.5;
end;
for J := 1 step 1 until N do K1[J] := FXYZJ × H;
X := XL + H / 3;
for JJ := 1 step 1 until N do
begin Y[JJ] := YL[JJ] + (ZL[JJ] × 6 + K0[JJ]) / 18 × H;
Z[JJ] := ZL[JJ] + (K0[JJ] + K1[JJ] × 3) / 12
end;
for J := 1 step 1 until N do K2[J] := FXYZJ × H;
X := XL + H × .5;
for JJ := 1 step 1 until N do
begin Y[JJ] := YL[JJ] + (ZL[JJ] × 8 + K0[JJ] + K2[JJ])
/ 16 × H;
Z[JJ] := ZL[JJ] + (K0[JJ] + K2[JJ] × 3) / 8
end;
for J := 1 step 1 until N do K3[J] := FXYZJ × H;
X := XL + H × .8;
for JJ := 1 step 1 until N do
begin Y[JJ] := YL[JJ] + (ZL[JJ] × 100 + K0[JJ] × 12 +
K3[JJ] × 28) / 125 × H;
Z[JJ] := ZL[JJ] + (K0[JJ] × 53 - K1[JJ] × 135 +
K2[JJ] × 126 + K3[JJ] × 56) / 125
end;
for J := 1 step 1 until N do K4[J] := FXYZJ × H;
X := if LAST then B else XL + H;
for JJ := 1 step 1 until N do
begin Y[JJ] := YL[JJ] + (ZL[JJ] × 336 + K0[JJ] × 21 +
K2[JJ] × 92 + K4[JJ] × 55) / 336 × H;
Z[JJ] := ZL[JJ] + (K0[JJ] × 133 - K1[JJ] × 378 +
K2[JJ] × 276 + K3[JJ] × 112 + K4[JJ] × 25) / 168
end;
for J := 1 step 1 until N do K5[J] := FXYZJ × H;
REJECT := false; FHM := 0;
for JJ := 1 step 1 until N do
begin DISCRY := ABS(( - K0[JJ] × 21 + K2[JJ] × 108 -
K3[JJ] × 112 + K4[JJ] × 25) / 56 × H);
DISCRZ := ABS(K0[JJ] × 21 - K2[JJ] × 162 + K3[JJ]
× 224 - K4[JJ] × 125 + K5[JJ] × 42) / 14;
TOLY := ABSH × (ABS(ZL[JJ]) × EE[2 × JJ - 1] +
EE[2 × JJ]);
TOLZ := ABS(K0[JJ]) × EE[2 × (JJ + N) - 1] + ABSH
× EE[2 × (JJ + N)];
REJECT := DISCRY > TOLY ∨ DISCRZ > TOLZ ∨ REJECT;
FHY := DISCRY / TOLY; FHZ := DISCRZ / TOLZ;
if FHZ > FHY then FHY := FHZ;
if FHY > FHM then FHM := FHY
end;
MU := 1 / (1 + FHM) + .45; if REJECT then
begin if ABSH ≤ HMIN then
begin D[1] := D[1] + 1;
for JJ := 1 step 1 until N do
begin Y[JJ] := YL[JJ]; Z[JJ] := ZL[JJ] end;
FIRST := true; goto NEXT
end;
H := MU × H; goto TEST
end;
if FIRST then
begin FIRST := false; HL := H; H := MU × H; goto ACC
end;
FHM := MU × H / HL + MU - MU1; HL := H; H := FHM × H;
ACC: MU1 := MU;
for JJ := 1 step 1 until N do
begin Y[JJ] := YL[JJ] + (ZL[JJ] × 56 + K0[JJ] × 7 +
K2[JJ] × 36 - K4[JJ] × 15) / 56 × HL;
Z[JJ] := ZL[JJ] + ( - K0[JJ] × 63 + K1[JJ] × 189
- K2[JJ] × 36 - K3[JJ] × 112 + K4[JJ] × 50) / 28
end;
for J := 1 step 1 until N do K5[J] := FXYZJ × HL;
for JJ := 1 step 1 until N do
begin Y[JJ] := YL[JJ] + (ZL[JJ] × 336 + K0[JJ] × 35 +
K2[JJ] × 108 + K4[JJ] × 25) / 336 × HL;
Z[JJ] := ZL[JJ] + (K0[JJ] × 35 + K2[JJ] × 162 +
K4[JJ] × 125 + K5[JJ] × 14) / 336
end;
NEXT: if B ≠ X then
begin XL := X;
for JJ := 1 step 1 until N do
begin YL[JJ] := Y[JJ]; ZL[JJ] := Z[JJ] end;
goto TEST
end;
if ¬LAST then D[2] := H; D[3] := X;
for JJ := 1 step 1 until N do
begin D[JJ + 3] := Y[JJ]; D[N + JJ + 3] := Z[JJ] end
end RK2N;
comment ================== 33014 ================= ;
procedure RK3(X, A, B, Y, YA, Z, ZA, FXY, E, D, FI);
value B, FI; real X, A, B, Y, YA, Z, ZA, FXY; Boolean FI;
array E, D;
begin real E1, E2, E3, E4, XL, YL, ZL, H, INT, HMIN, HL,
ABSH, K0, K1, K2, K3, K4, K5, DISCRY, DISCRZ, TOLY,
TOLZ, MU, MU1, FHY, FHZ;
Boolean LAST, FIRST, REJECT;
if FI then
begin D[3] := A; D[4] := YA; D[5] := ZA end;
D[1] := 0; XL := D[3]; YL := D[4]; ZL := D[5];
if FI then D[2] := B - D[3]; ABSH := H := ABS(D[2]);
if B - XL < 0 then H := - H; INT := ABS(B - XL);
HMIN := INT × E[1] + E[2]; HL := INT × E[3] + E[4];
if HL < HMIN then HMIN := HL; E1 := E[1] / INT;
E2 := E[2] / INT; E3 := E[3] / INT; E4 := E[4] / INT;
FIRST := REJECT := true; if FI then
begin LAST := true; goto STEP end;
TEST: ABSH := ABS(H); if ABSH < HMIN then
begin H := if H > 0 then HMIN else - HMIN; ABSH := HMIN
end;
if H ≥ B - XL equiv H ≥ 0 then
begin D[2] := H; LAST := true; H := B - XL;
ABSH := ABS(H)
end
else LAST := false;
STEP: if REJECT then
begin X := XL; Y := YL; K0 := FXY × H end
else K0 := K5 × H / HL; X := XL + .276393202250021 × H;
Y := YL + (ZL × .2763932022 50021 + K0 ×
.038196601125011) × H; K1 := FXY × H;
X := XL + .72360 6797749979 × H;
Y := YL + (ZL × .723606797749979 + K1 × .26180
3398874989) × H; K2 := FXY × H; X := XL + H × .5;
Y := YL + (ZL × .5 + K0 × .046875 + K1 ×
.079824155839840 - K2 × .001699155839840) × H;
K4 := FXY × H; X := if LAST then B else XL + H;
Y := YL + (ZL + K0 × .309016994374947 + K2 ×
.190983005625053) × H; K3 := FXY × H;
Y := YL + (ZL + K0 × .083333333333333 + K1 ×
.301502832395825 + K2 × .115163834270842) × H;
K5 := FXY × H;
DISCRY := ABS(( - K0 × .5 + K1 × 1.809016994374947 +
K2 × .690983005625053 - K4 × 2) × H);
DISCRZ := ABS((K0 - K3) × 2 - (K1 + K2) × 10 + K4 ×
16 + K5 × 4); TOLY := ABSH × (ABS(ZL) × E1 + E2);
TOLZ := ABS(K0) × E3 + ABSH × E4;
REJECT := DISCRY > TOLY ∨ DISCRZ > TOLZ;
FHY := DISCRY / TOLY; FHZ := DISCRZ / TOLZ;
if FHZ > FHY then FHY := FHZ;
MU := 1 / (1 + FHY) + .45; if REJECT then
begin if ABSH ≤ HMIN then
begin D[1] := D[1] + 1; Y := YL; Z := ZL;
FIRST := true; goto NEXT
end;
H := MU × H; goto TEST
end;
if FIRST then
begin FIRST := false; HL := H; H := MU × H; goto ACC
end;
FHY := MU × H / HL + MU - MU1; HL := H; H := FHY × H;
ACC: MU1 := MU;
Z := ZL + (K0 + K3) × .083333333333333 + (K1 + K2) ×
.416666666666667;
NEXT: if B ≠ X then
begin XL := X; YL := Y; ZL := Z; goto TEST end;
if ¬LAST then D[2] := H; D[3] := X; D[4] := Y; D[5] := Z
end RK3;
comment ================== 33015 ================= ;
procedure RK3N(X, A, B, Y, YA, Z, ZA, FXYJ, J, E, D,
FI, N); value B, FI, N; integer J, N; real X, A, B, FXYJ;
Boolean FI; array Y, YA, Z, ZA, E, D;
begin integer JJ;
real XL, H, HMIN, INT, HL, ABSH, FHM, DISCRY, DISCRZ,
TOLY, TOLZ, MU, MU1, FHY, FHZ;
Boolean LAST, FIRST, REJECT;
array YL, ZL, K0, K1, K2, K3, K4, K5[1:N], EE[1:4 ×
N];
if FI then
begin D[3] := A;
for JJ := 1 step 1 until N do
begin D[JJ + 3] := YA[JJ]; D[N + JJ + 3] := ZA[JJ]
end
end;
D[1] := 0; XL := D[3];
for JJ := 1 step 1 until N do
begin YL[JJ] := D[JJ + 3]; ZL[JJ] := D[N + JJ + 3] end;
if FI then D[2] := B - D[3]; ABSH := H := ABS(D[2]);
if B - XL < 0 then H := - H; INT := ABS(B - XL);
HMIN := INT × E[1] + E[2];
for JJ := 2 step 1 until 2 × N do
begin HL := INT × E[2 × JJ - 1] + E[2 × JJ];
if HL < HMIN then HMIN := HL
end;
for JJ := 1 step 1 until 4 × N do EE[JJ] := E[JJ] / INT;
FIRST := REJECT := true; if FI then
begin LAST := true; goto STEP end;
TEST: ABSH := ABS(H); if ABSH < HMIN then
begin H := if H > 0 then HMIN else - HMIN; ABSH := HMIN
end;
if H ≥ B - XL equiv H ≥ 0 then
begin D[2] := H; LAST := true; H := B - XL;
ABSH := ABS(H)
end
else LAST := false;
STEP: if REJECT then
begin X := XL;
for JJ := 1 step 1 until N do Y[JJ] := YL[JJ];
for J := 1 step 1 until N do K0[J] := FXYJ × H
end
else
begin FHY := H / HL;
for JJ := 1 step 1 until N do K0[JJ] := K5[JJ] × FHY
end;
X := XL + .27639 3202250021 × H;
for JJ := 1 step 1 until N do Y[JJ] := YL[JJ] + (ZL[JJ]
× .276393202250021 + K0[JJ] × .038196601125011) × H;
for J := 1 step 1 until N do K1[J] := FXYJ × H;
X := XL + .723606797749979 × H;
for JJ := 1 step 1 until N do Y[JJ] := YL[JJ] + (ZL[JJ]
× .723606797749979 + K1[JJ] × .261803398874989) × H;
for J := 1 step 1 until N do K2[J] := FXYJ × H;
X := XL + H × .5;
for JJ := 1 step 1 until N do Y[JJ] := YL[JJ] + (ZL[JJ]
× .5 + K0[JJ] × .046875 + K1[JJ] × .079824155839840
- K2[JJ] × .00169 9155839840) × H;
for J := 1 step 1 until N do K4[J] := FXYJ × H;
X := if LAST then B else XL + H;
for JJ := 1 step 1 until N do Y[JJ] := YL[JJ] + (ZL[JJ]
+ K0[JJ] × .309016994374947 + K2[JJ] ×
.190983005625053) × H;
for J := 1 step 1 until N do K3[J] := FXYJ × H;
for JJ := 1 step 1 until N do Y[JJ] := YL[JJ] + (ZL[JJ]
+ K0[JJ] × .083333333333333 + K1[JJ] × .30150
2832395825 + K2[JJ] × .115163834270842) × H;
for J := 1 step 1 until N do K5[J] := FXYJ × H;
REJECT := false; FHM := 0;
for JJ := 1 step 1 until N do
begin DISCRY := ABS(( - K0[JJ] × .5 + K1[JJ] ×
1.809016994374947 + K2[JJ] × .690983005625053 -
K4[JJ] × 2) × H);
DISCRZ := ABS((K0[JJ] - K3[JJ]) × 2 - (K1[JJ] +
K2[JJ]) × 10 + K4[JJ] × 16 + K5[JJ] × 4);
TOLY := ABSH × (ABS(ZL[JJ]) × EE[2 × JJ - 1] +
EE[2 × JJ]);
TOLZ := ABS(K0[JJ]) × EE[2 × (JJ + N) - 1] + ABSH
× EE[2 × (JJ + N)];
REJECT := DISCRY > TOLY ∨ DISCRZ > TOLZ ∨ REJECT;
FHY := DISCRY / TOLY; FHZ := DISCRZ / TOLZ;
if FHZ > FHY then FHY := FHZ;
if FHY > FHM then FHM := FHY
end;
MU := 1 / (1 + FHM) + .45; if REJECT then
begin if ABSH ≤ HMIN then
begin D[1] := D[1] + 1;
for JJ := 1 step 1 until N do
begin Y[JJ] := YL[JJ]; Z[JJ] := ZL[JJ] end;
FIRST := true; goto NEXT
end;
H := MU × H; goto TEST
end REJ;
if FIRST then
begin FIRST := false; HL := H; H := MU × H; goto ACC
end;
FHY := MU × H / HL + MU - MU1; HL := H; H := FHY × H;
ACC: MU1 := MU;
for JJ := 1 step 1 until N do Z[JJ] := ZL[JJ] + (K0[JJ]
+ K3[JJ]) × .083333333333333 + (K1[JJ] + K2[JJ]) ×
.416666666666667;
NEXT: if B ≠ X then
begin XL := X;
for JJ := 1 step 1 until N do
begin YL[JJ] := Y[JJ]; ZL[JJ] := Z[JJ] end;
goto TEST
end;
if ¬LAST then D[2] := H; D[3] := X;
for JJ := 1 step 1 until N do
begin D[JJ + 3] := Y[JJ]; D[N + JJ + 3] := Z[JJ] end
end RK3N;
comment ================== 35120 ================= ;
real procedure TAN(X); value X; real X;
begin real U;
Boolean procedure OVERFLOW(X); code 30009;
real procedure GIANT; code 30004;
U := SIN(X)/COS(X);
TAN := if OVERFLOW(U) then GIANT else U
end TAN;
comment ================== 35111 ================= ;
real procedure SINH(X); value X; real X;
begin real AX, Y;
AX := ABS(X);
if AX < 0.3 then
begin Y := if AX < 0.1 then X × X else X × X/9;
X := ((( 0.0001984540 × Y +
0.0083333331783 ) × Y +
0.16666666666675) × Y +
1.0 ) × X ;
SINH := if AX < 0.1 then X else
X × ( 1.0 + 0.14814814814815 × X × X )
end else if AX < 17.5 then
begin AX := EXP( AX ); SINH := SIGN(X) × .5 × ( AX -1/AX ) end
else if AX > 742.36063037970 then
begin real procedure GIANT; code 30004;
SINH := SIGN(X) × GIANT
end else
SINH := SIGN(X) × EXP(AX- .69314 71805 59945)
end SINH;
comment ================== 35115 ================= ;
real procedure ARCCOSH(X); value X; real X;
ARCCOSH := if X ≤ 1 then 0 else
if X > 1010 then 0.69314718055995 + LN(X) else
LN(X + SQRT((X-1) × (X + 1)));
comment ================== 35080 ================= ;
real procedure EI(X); value X; real X;
begin real array P, Q[0:7];
real procedure CHEPOLSER(N, X, A); code 31046;
real procedure POL(N, X, A); code 31040;
real procedure JFRAC(N, A, B); code 35083;
if X > 24 then
begin P[0] := + 1.00000000000058 ; Q[1] := 1.99999999924131 ;
P[1] := X-3.00000016782085 ; Q[2] := -2.99996432944446 ;
P[2] := X-5.00140345515924 ; Q[3] := -7.90404992298926 ;
P[3] := X-7.49289167792884 ; Q[4] := -4.31325836146628 ;
P[4] := X-3.0833626905176310+1; Q[5] := 2.9599939948683110+2;
P[5] := X-1.39381360364405 ; Q[6] := -6.74704580465832 ;
P[6] := X + 8.91263822573708 ; Q[7] := 1.0474536265246810+3;
P[7] := X-5.3168662349448210+1;
EI := EXP(X) × (1 + JFRAC(7, Q, P)/X)/X
end else if X > 12 then
begin P[0] := + 9.9999429607470810-1; Q[1] := 1.00083867402639 ;
P[1] := X-1.95022321289660 ; Q[2] := -3.43942266899870 ;
P[2] := X + 1.75656315469614 ; Q[3] := 2.8951672792513510+1;
P[3] := X + 1.7960168876925210+1; Q[4] := 7.6076114800773510+2;
P[4] := X-3.2346733030540310+1; Q[5] := 2.5777638423844010+1;
P[5] := X-8.28561994140641 ; Q[6] := 5.7283719383732410+1;
P[6] := X-1.8654545488339910+1; Q[7] := 6.9500065588743410+1;
P[7] := X-3.48334653602853 ;
EI := EXP(X) × JFRAC(7, Q, P)/X
end else if X > 6 then
begin P[0] := + 1.00443109228078 ; Q[1] := 5.2746885196290810-1;
P[1] := X-4.3253113287813510+1; Q[2] := 2.7362411988932810+3;
P[2] := X + 6.0121799083008010+1; Q[3] := 1.4325673812193810+1;
P[3] := X-3.3184253199722110+1; Q[4] := 1.0036743951672610+3;
P[4] := X + 2.5076281129356010+1; Q[5] := -6.25041161671876 ;
P[5] := X + 9.30816385662165 ; Q[6] := 3.0089264837291510+2;
P[6] := X-2.1901023385488010+1; Q[7] := 3.93707701852715 ;
P[7] := X-2.18086381520724 ;
EI := EXP(X) × JFRAC(7, Q, P)/X
end else if X > 0 then
begin real T, R, X0, XMX0;
P[0] := -1.9577303690454810+8; Q[0] := -8.2627149862605510+7;
P[1] := 3.8928042131120110+6; Q[1] := 8.9192576757561210+7;
P[2] := -2.2174462775884510+7; Q[2] := -2.4903337574054010+7;
P[3] := -1.1962366934924710+5; Q[3] := 4.2855962461174910+6;
P[4] := -2.4930139345864810+5; Q[4] := -4.8354743616216410+5;
P[5] := -4.2100161535707010+3; Q[5] := 3.5730029805850810+4;
P[6] := -5.4914226552108510+2; Q[6] := -1.6070892658722110+3;
P[7] := -8.66937339951070 ; Q[7] := 3.4171875000000010+1;
X0 := .372507410781367;
T := X/3-1;
R := CHEPOLSER(7, T, P)/CHEPOLSER(7, T, Q);
XMX0 := (X-409576229586/1099511627776)-.76717725019939410-12;
if ABS(XMX0) > .037 then T := LN(X/X0) else
begin real Z, Z2;
P[0] := .83720793397607510+1; Q[0] := .41860396698803710+1;
P[1] := -.65226874083710310+1; Q[1] := -.46566902608081410+1;
P[2] := .569955700306720 ; Q[2] := .110+1;
Z := XMX0/(X + X0); Z2 := Z × Z;
T := Z × POL(2, Z2, P)/POL(2, Z2, Q)
end;
EI := T + XMX0 × R
end else
if X > -1 then
begin real Y;
P[0] := -4.4178547172821710+4; Q[0] := 7.6537332333761410+4;
P[1] := 5.7721724713944410+4; Q[1] := 3.2597188129027510+4;
P[2] := 9.9383138896203710+3; Q[2] := 6.1061079424575910+3;
P[3] := 1.8421108866800010+3; Q[3] := 6.3541941837838210+2;
P[4] := 1.0109380616190610+2; Q[4] := 3.7229835283332710+1;
P[5] := 5.03416184097568 ; Q[5] := 1;
Y := -X;
EI := LN(Y)-POL(5, Y, P)/POL(5, Y, Q)
end else if X > -4 then
begin real Y;
P[0] := 8.6774595483844410-8; Q[0] := 1;
P[1] := 9.9999551930139010-1; Q[1] := 1.2848193537915710+1;
P[2] := 1.1848310555494610+1; Q[2] := 5.6443356956180310+1;
P[3] := 4.5593064425339010+1; Q[3] := 1.0664518376991410+2;
P[4] := 6.9927945129100310+1; Q[4] := 8.9731109712529010+1;
P[5] := 4.2520203476884110+1; Q[5] := 3.1497184917044110+1;
P[6] := 8.83671808803844 ; Q[6] := 3.79559003762122 ;
P[7] := 4.0137766494066510-1; Q[7] := 9.0880456918886910-2;
Y := -1/X;
EI := -EXP(X) × POL(7, Y, P)/POL(7, Y, Q)
end else
begin real Y;
P[0] := -9.9999999999844710-1; Q[0] := 1;
P[1] := -2.6627106043181110+1; Q[1] := 2.8627106042219210+1;
P[2] := -2.4105582709701510+2; Q[2] := 2.9231003938853310+2;
P[3] := -8.9592795777293710+2; Q[3] := 1.3327853774825710+3;
P[4] := -1.2988568874648410+3; Q[4] := 2.7776194950916310+3;
P[5] := -5.4537415888313310+2; Q[5] := 2.4040171322590910+3;
P[6] := -5.66575206533869 ; Q[6] := 6.3165748328080010+2;
Y := -1/X;
EI := -EXP(X) × Y × (1 + Y × POL(6, Y, P)/POL(6, Y, Q))
end
end EI;
comment ================== 35086 ================= ;
procedure ENX(X, N1, N2, A);
value X, N1, N2;
real X; integer N1, N2; array A;
if X ≤ 1.5 then
begin
real procedure EI(X); code 35080;
real W, E; integer I;
W := -EI(-X);
if N1 = 1 then A[1] := W;
if N2 > 1 then E := EXP(-X);
for I := 2 step 1 until N2 do
begin
W := (E - X × W)/(I - 1);
if I ≥ N1 then A[I] := W
end
end else
begin integer I, N; real W, E, AN;
N := ENTIER(X + .5);
if N ≤ 10 then
begin real F, W1, T, H;
real array P[2:19];
P[ 2] := .3753426182049110-1; P[11] := .135335283236613 ;
P[ 3] := .8930646556022810-2; P[12] := .49787068367863910-1;
P[ 4] := .2423398368658110-2; P[13] := .18315638888734210-1;
P[ 5] := .7057606934245810-3; P[14] := .67379469990854710-2;
P[ 6] := .2148027781901310-3; P[15] := .24787521766663610-2;
P[ 7] := .6737580778101810-4; P[16] := .91188196555451610-3;
P[ 8] := .2160073015997510-4; P[17] := .33546262790251210-3;
P[ 9] := .7041157985429210-5; P[18] := .12340980408668010-3;
P[10] := .2325302657028210-5; P[19] := .45399929762484810-4;
F := W := P[N];
E := P[N + 9];
W1 := T := 1;
H := X-N;
for I := N-1, I-1 while ABS(W1) > 10-15 × W do
begin
F := (E - I × F)/N;
T := -H × T / (N-I);
W1 := T × F; W := W + W1
end
end else
begin
procedure NONEXPENX(X, N1, N2, A); code 35087;
array B[N:N];
NONEXPENX(X, N, N, B);
W := B[N] × EXP(-X)
end;
if N1 = N2 ∧ N1 = N then A[N] := W else
begin
E := EXP(-X);
AN := W;
if N ≤ N2 ∧ N ≥ N1 then A[N] := W;
for I := N-1 step -1 until N1 do
begin
W := (E - I × W)/X;
if I ≤ N2 then A[I] := W
end;
W := AN;
for I := N + 1 step 1 until N2 do
begin
W := (E - X × W)/(I - 1);
if I ≥ N1 then A[I] := W
end
end
end ENX;
comment ================== 35087 ================= ;
procedure NONEXPENX(X, N1, N2, A);
value X, N1, N2;
real X; integer N1, N2; array A;
begin integer I, N; real W, AN;
N := if X ≤ 1.5 then 1 else ENTIER(X + .5);
if N ≤ 10 then
begin
procedure ENX(X, N1, N2, A); code 35086;
array B[N:N];
ENX(X, N, N, B);
W := B[N] × EXP(X)
end else
begin
integer K, K1;
real UE, VE, WE, WE1, UO, VO, WO, WO1, R, S;
UE := 1; VE := WE := 1/(X + N); WE1 := 0;
UO := 1; VO := -N/(X × (X + N + 1)); WO1 := 1/X; WO := VO + WO1;
W := (WE + WO)/2;
K1 := 1;
for K := K1 while WO-WE > 10-15 × W ∧ WE > WE1 ∧ WO < WO1 do
begin
WE1 := WE; WO1 := WO;
R := N + K; S := R + X + K;
UE := 1/(1-K × (R-1) × UE/((S-2) × S));
UO := 1/(1-K × R × UO/( S × S-1));
VE := VE × (UE-1);
VO := VO × (UO-1);
WE := WE + VE;
WO := WO + VO;
W := (WE + WO)/2;
K1 := K1 + 1
end
end;
AN := W;
if N ≤ N2 ∧ N ≥ N1 then A[N] := W;
for I := N-1 step -1 until N1 do
begin
W := (1 - I × W)/X;
if I ≤ N2 then A[I] := W
end;
W := AN;
for I := N + 1 step 1 until N2 do
begin
W := (1 - X × W)/(I - 1);
if I ≥ N1 then A[I] := W
end
end EXPENX;
comment ================== 35084 ================= ;
procedure SINCOSINT(X, SI, CI); value X; real X, SI, CI;
begin real ABSX, Z, F, G;
procedure SINCOSFG(X, F, G); code 35085;
real procedure CHEPOLSER(N, X, A); code 31046;
ABSX := ABS(X);
if ABSX ≤ 4 then
begin real array A[0:10]; real Z2;
A[0] := + 2.736870680363010+00; A[1] := -1.110631410789410+00;
A[2] := + 1.417656219466610-01; A[3] := -1.025265257917410-02;
A[4] := + 4.649461561988010-04; A[5] := -1.436173089664210-05;
A[6] := + 3.209368494822910-07; A[7] := -5.425199077016210-09;
A[8] := + 7.177628863989510-11; A[9] := -7.633549372348210-13;
A[10] := + 6.667995834698310-15;
Z := X / 4; Z2 := Z × Z; G := Z2 + Z2 - 1;
SI := Z × CHEPOLSER(10, G, A);
A[0] := + 2.965960140072710+00; A[1] := -9.429719834183010-01;
A[2] := + 8.611034273816910-02; A[3] := -4.777608454713910-03;
A[4] := + 1.752916120514610-04; A[5] := -4.544872780375210-06;
A[6] := + 8.751583918006010-08; A[7] := -1.299869993810910-09;
A[8] := + 1.533897489883110-11; A[9] := -1.472425607027710-13;
A[10] := + 1.172142079842910-15;
CI := .577215664901533 + LN(ABSX) - Z2 × CHEPOLSER(10, G, A)
end else
begin real CX, SX;
SINCOSFG(X, F, G);
CX := COS(X); SX := SIN(X);
SI := 1.570796326794897; if X < 0 then SI := -SI;
SI := SI - F × CX - G × SX;
CI := F × SX - G × CX
end
end SINCOSINT;
comment ================== 35085 ================= ;
procedure SINCOSFG(X, F, G); value X; real X, F, G;
begin real ABSX, SI, CI;
procedure SINCOSINT(X, SI, CI); code 35084;
real procedure CHEPOLSER(N, X, A); code 31046;
ABSX := ABS(X);
if ABSX ≤ 4 then
begin real CX, SX;
SINCOSINT(X, SI, CI);
CX := COS(X); SX := SIN(X); SI := SI - 1.570796326794897;
F := CI × SX - SI × CX;
G := -CI × CX - SI × SX
end else
begin real array A[0:23];
A[0] := + 9.657882803518510-01; A[1] := -4.306083777859710-02;
A[2] := -7.314371174810410-03; A[3] := + 1.470523578986810-03;
A[4] := -9.865768573270210-05; A[5] := -2.274320220465510-05;
A[6] := + 9.824025732252610-06; A[7] := -1.897343014871310-06;
A[8] := + 1.006343594155810-07; A[9] := + 8.081936482224110-08;
A[10] := -3.897628287528810-08; A[11] := + 1.033565032549710-08;
A[12] := -1.410434487589710-09; A[13] := -2.523207839968310-10;
A[14] := + 2.569983132596110-10; A[15] := -1.059788925394810-10;
A[16] := + 2.897003157021410-11; A[17] := -4.102314256308310-12;
A[18] := -1.043769373001810-12; A[19] := + 1.099418452054710-12;
A[20] := -5.221423940167910-13; A[21] := + 1.746992078782910-13;
A[22] := -3.847001297927910-14;
F := CHEPOLSER(22, 8/ABSX-1, A) / X;
A[0] := + 2.280122063824110-01; A[1] := -2.686972741109710-02;
A[2] := -3.510715728095810-03; A[3] := + 1.239800863518610-03;
A[4] := -1.567294511686210-04; A[5] := -1.066414179809410-05;
A[6] := + 1.117062934357410-05; A[7] := -3.175401165561410-06;
A[8] := + 4.431747352039810-07; A[9] := + 5.510869687446310-08;
A[10] := -5.924307871174310-08; A[11] := + 2.210257338155510-08;
A[12] := -5.025682754062310-09; A[13] := + 3.151916825942410-10;
A[14] := + 3.630699084897910-10; A[15] := -2.297476423459110-10;
A[16] := + 8.553030942404810-11; A[17] := -2.118306772444310-11;
A[18] := + 1.713366264509210-12; A[19] := + 1.723887751724810-12;
A[20] := -1.293028136681110-12; A[21] := + 5.747233922373110-13;
A[22] := -1.841546826831410-13; A[23] := + 3.593725657143410-14;
G := 4 × CHEPOLSER(23, 8/ABSX-1, A) / ABSX /ABSX
end
end SINCOSFG;
comment ================== 35060 ================= ;
real procedure RECIP GAMMA(X, ODD, EVEN);
value X; real X, ODD, EVEN;
begin integer I;
real ALFA, BETA, X2;
array B[1:12];
B[ 1] := -.28387 65422 76024; B[ 2] := -.07685 28408 44786;
B[ 3] := + .00170 63050 71096; B[ 4] := + .00127 19271 36655;
B[ 5] := + .00007 63095 97586; B[ 6] := -.00000 49717 36704;
B[ 7] := -.00000 08659 20800; B[ 8] := -.00000 00331 26120;
B[ 9] := + .00000 00017 45136; B[10] := + .00000 00002 42310;
B[11] := + .00000 00000 09161; B[12] := -.00000 00000 00170;
X2 := X × X × 8;
ALFA := -.00000 00000 00001; BETA := 0;
for I := 12 step - 2 until 2 do
begin BETA := -(ALFA × 2 + BETA); ALFA := - BETA × X2 - ALFA + B[I]
end;
EVEN := (BETA / 2 + ALFA) × X2 - ALFA + .92187 02936 50453;
ALFA := -.00000 00000 00034; BETA := 0;
for I := 11 step - 2 until 1 do
begin BETA := -(ALFA × 2 + BETA); ALFA := - BETA × X2 - ALFA + B[I]
end;
ODD := (ALFA + BETA) × 2;
RECIP GAMMA := ODD × X + EVEN
end RECIP GAMMA;
comment ================== 35061 ================= ;
real procedure GAMMA(X); value X; real X;
begin real Y, S, F, G, ODD, EVEN;
Boolean INV;
real procedure RECIP GAMMA(X, ODD, EVEN);
value X; real X, ODD, EVEN;
code 35060;
real procedure LOG GAMMA(X); value X; real X;
code 35062;
if X < .5 then
begin Y := X - ENTIER(X / 2) × 2; S := 3.14159 26535 8979;
if Y ≥ 1 then begin S := - S; Y := 2 - Y end;
if Y ≥ .5 then Y := 1 - Y; INV := true; X := 1 - X;
F := S / SIN(3.14159 26535 8979 × Y)
end
else INV := false;
if X > 22 then G := EXP(LOG GAMMA(X)) else
begin S := 1;
NEXT: if X > 1.5 then
begin X := X - 1; S := S × X; goto NEXT end;
G := S / RECIP GAMMA(1 - X, ODD, EVEN)
end;
GAMMA := if INV then F / G else G
end GAMMA;
comment ================== 35062 ================= ;
real procedure LOG GAMMA(X); value X; real X;
if X > 13 then
begin real R, X2;
R := 1;
NEXT: if X ≤ 22 then
begin R := R / X; X := X + 1; goto NEXT end;
X2 := - 1 / (X × X); R := LN(R);
LOG GAMMA := LN(X) × (X - .5) - X + R + .91893 85332 04672 +
(((.59523 80952 3809510-3 × X2 + .79365 07936 5079410-3) × X2 +
.27777 77777 7777810-2) × X2 + .83333 33333 3333310-1) / X
end
else
begin real Y, F, U0, U1, U, Z;
integer I;
array B[1:18];
F := 1; U0 := U1 := 0;
B[ 1] := -.07611 41616 704358; B[ 2] := + .00843 23249 659328;
B[ 3] := -.00107 94937 263286; B[ 4] := + .00014 90074 800369;
B[ 5] := -.00002 15123 998886; B[ 6] := + .00000 31979 329861;
B[ 7] := -.00000 04851 693012; B[ 8] := + .00000 00747 148782;
B[ 9] := -.00000 00116 382967; B[10] := + .00000 00018 294004;
B[11] := -.00000 00002 896918; B[12] := + .00000 00000 461570;
B[13] := -.00000 00000 073928; B[14] := + .00000 00000 011894;
B[15] := -.00000 00000 001921; B[16] := + .00000 00000 000311;
B[17] := -.00000 00000 000051; B[18] := + .00000 00000 000008;
if X < 1 then
begin F := 1 / X; X := X + 1 end
else
NEXT: if X > 2 then
begin X := X - 1; F := F × X; goto NEXT end;
F := LN(F); Y := X + X - 3; Z := Y + Y;
for I := 18 step - 1 until 1 do
begin U := U0; U0 := Z × U0 + B[I] - U1; U1 := U end;
LOG GAMMA := (U0 × Y + .49141 53930 29387 - U1) × (X - 1) × (X - 2)
+ F
end LOG GAMMA;
comment ================== 35030 ================= ;
procedure INCOMGAM(X, A, KLGAM, GRGAM, GAM, EPS);
value X, A, EPS; real X, A, KLGAM, GRGAM, GAM, EPS;
begin real C0, C1, C2, D0, D1, D2, X2, AX, P, Q, R, S, R1, R2, SCF;
integer N;
S := EXP(-X + A × LN(X)); SCF := 10+300;
if X ≤ (if A < 3 then 1 else A) then
begin X2 := X × X; AX := A × X; D0 := 1; P := A; C0 := S;
D1 := (A + 1) × (A + 2-X); C1 := ((A + 1) × (A + 2) + X) × S;
R2 := C1/D1;
for N := 1, N + 1 while ABS((R2-R1)/R2) > EPS do
begin P := 2 + P; Q := (P + 1) × (P × (P + 2)-AX);
R := N × (N + A) × (P + 2) × X2;
C2 := (Q × C1 + R × C0)/P; D2 := (Q × D1 + R × D0)/P;
R1 := R2; R2 := C2/D2;
C0 := C1; C1 := C2; D0 := D1; D1 := D2;
if ABS(C1) > SCF ∨ ABS(D1) > SCF then
begin C0 := C0/SCF; C1 := C1/SCF;
D0 := D0/SCF; D1 := D1/SCF
end
end; KLGAM := R2/A; GRGAM := GAM - KLGAM
end else
begin C0 := A × S; C1 := (1 + X) × C0; Q := X + 2 - A;
D0 := X; D1 := X × Q; R2 := C1/D1;
for N := 1, N + 1 while ABS((R2-R1)/R2) > EPS do
begin Q := 2 + Q; R := N × (N + 1-A);
C2 := Q × C1-R × C0; D2 := Q × D1-R × D0;
R1 := R2; R2 := C2/D2;
C0 := C1; C1 := C2; D0 := D1; D1 := D2;
if ABS(C1) > SCF ∨ ABS(D1) > SCF then
begin C0 := C0/SCF; C1 := C1/SCF;
D0 := D0/SCF; D1 := D1/SCF
end
end; GRGAM := R2/A; KLGAM := GAM - GRGAM
end
end INCOMGAM;
comment ================== 35050 ================= ;
real procedure INCBETA(X, P, Q, EPS);
value X, P, Q, EPS; real X, P, Q, EPS;
begin integer M, N; real G, F, FN, FN1, FN2, GN, GN1, GN2, DN, PQ;
Boolean N EVEN, RECUR;
real procedure GAMMA(X); value X; real X;
code 35061;
if X = 0 ∨ X = 1 then INCBETA := X else
begin if X > .5 then
begin F := P; P := Q; Q := F; X := 1-X; RECUR := true end
else RECUR := false;
G := FN2 := 0; M := 0; PQ := P + Q; F := FN1 := GN1 := GN2 := 1;
N EVEN := false;
for N := 1, N + 1 while ABS((F-G)/F) > EPS do
begin if N EVEN then
begin M := M + 1; DN := M × X × (Q-M)/(P + N-1)/(P + N) end
else DN := -X × (P + M) × (PQ + M)/(P + N-1)/(P + N);
G := F; FN := FN1 + DN × FN2; GN := GN1 + DN × GN2;
N EVEN := ¬N EVEN; F := FN/GN;
FN2 := FN1; FN1 := FN; GN2 := GN1; GN1 := GN
end;
F := F × X⭡P × (1-X)⭡Q × GAMMA(P + Q)/GAMMA(P + 1)/GAMMA(Q);
if RECUR then F := 1-F;
INCBETA := F
end
end INCBETA;
comment ================== 35051 ================= ;
procedure IBPPLUSN(X, P, Q, NMAX, EPS, I); value X, P, Q, NMAX, EPS;
integer NMAX; real X, P, Q, EPS; array I;
begin integer N;
procedure IXQFIX(X, P, Q, NMAX, EPS, I); value X, P, Q, NMAX, EPS;
real X, P, Q, EPS; integer NMAX; array I;
code 35053;
procedure IXPFIX(X, P, Q, NMAX, EPS, I); value X, P, Q, NMAX, EPS;
real X, P, Q, EPS; integer NMAX; array I;
code 35054;
if X = 0 ∨ X = 1 then
begin for N := 0 step 1 until NMAX do I[N] := X end
else
begin if X ≤ .5 then IXQFIX(X, P, Q, NMAX, EPS, I) else
begin IXPFIX(1-X, Q, P, NMAX, EPS, I);
for N := 0 step 1 until NMAX do I[N] := 1-I[N]
end
end
end IBPPLUSN;
comment ================== 35052 ================= ;
procedure IBQPLUSN(X, P, Q, NMAX, EPS, I); value X, P, Q, NMAX, EPS;
integer NMAX; real X, P, Q, EPS; array I;
begin integer N;
procedure IXQFIX(X, P, Q, NMAX, EPS, I); value X, P, Q, NMAX, EPS;
real X, P, Q, EPS; integer NMAX; array I;
code 35053;
procedure IXPFIX(X, P, Q, NMAX, EPS, I); value X, P, Q, NMAX, EPS;
real X, P, Q, EPS; integer NMAX; array I;
code 35054;
if X = 0 ∨ X = 1 then
begin for N := 0 step 1 until NMAX do I[N] := X end
else
begin if X ≤ .5 then IXPFIX(X, P, Q, NMAX, EPS, I) else
begin IXQFIX(1-X, Q, P, NMAX, EPS, I);
for N := 0 step 1 until NMAX do I[N] := 1-I[N]
end
end
end IBQPLUSN;
comment ================== 35053 ================= ;
procedure IXQFIX(X, P, Q, NMAX, EPS, I); value X, P, Q, NMAX, EPS;
real X, P, Q, EPS; integer NMAX; array I;
begin integer M, MMAX; real S, IQ0, IQ1, Q0;
real procedure INCBETA(X, P, Q, EPS);
value X, P, Q, EPS; real X, P, Q, EPS;
code 35050;
procedure FORWARD(X, P, Q, I0, I1, NMAX, I);
value X, P, Q, I0, I1, NMAX; integer NMAX; real X, P, Q, I0, I1;
array I;
code 35055;
procedure BACKWARD(X, P, Q, I0, NMAX, EPS, I);
value X, P, Q, I0, NMAX, EPS; integer NMAX; real X, P, Q, I0, EPS;
array I;
code 35056;
M := ENTIER(Q); S := Q-M; Q0 := if S > 0 then S else S + 1;
MMAX := if S > 0 then M else M-1;
IQ0 := INCBETA(X, P, Q0, EPS);
if MMAX > 0 then IQ1 := INCBETA(X, P, Q0 + 1, EPS);
begin array IQ[0:MMAX];
FORWARD(X, P, Q0, IQ0, IQ1, MMAX, IQ);
BACKWARD(X, P, Q, IQ[MMAX], NMAX, EPS, I)
end
end IXQFIX;
comment ================== 35054 ================= ;
procedure IXPFIX(X, P, Q, NMAX, EPS, I); value X, P, Q, NMAX, EPS;
real X, P, Q, EPS; integer NMAX; array I;
begin integer M, MMAX; real S, P0, I0, I1, IQ0, IQ1;
real procedure INCBETA(X, P, Q, EPS);
value X, P, Q, EPS; real X, P, Q, EPS;
code 35050;
procedure FORWARD(X, P, Q, I0, I1, NMAX, I);
value X, P, Q, I0, I1, NMAX; integer NMAX; real X, P, Q, I0, I1;
array I;
code 35055;
procedure BACKWARD(X, P, Q, I0, NMAX, EPS, I);
value X, P, Q, I0, NMAX, EPS; integer NMAX; real X, P, Q, I0, EPS;
array I;
code 35056;
M := ENTIER(P); S := P-M; P0 := if S > 0 then S else S + 1;
MMAX := if S > 0 then M else M-1;
I0 := INCBETA(X, P0, Q, EPS);
I1 := INCBETA(X, P0, Q + 1, EPS);
begin array IP[0:MMAX];
BACKWARD(X, P0, Q, I0, MMAX, EPS, IP); IQ0 := IP[MMAX];
BACKWARD(X, P0, Q + 1, I1, MMAX, EPS, IP); IQ1 := IP[MMAX]
end;
FORWARD(X, P, Q, IQ0, IQ1, NMAX, I)
end IXPFIX;
comment ================== 35055 ================= ;
procedure FORWARD(X, P, Q, I0, I1, NMAX, I);
value X, P, Q, I0, I1, NMAX; integer NMAX; real X, P, Q, I0, I1;
array I;
begin integer M, N; real Y, R, S;
I[0] := I0; if NMAX > 0 then I[1] := I1;
M := NMAX-1; R := P + Q-1; Y := 1-X;
for N := 1 step 1 until M do
begin S := (N + R) × Y;
I[N + 1] := ((N + Q + S) × I[N]-S × I[N-1])/(N + Q)
end
end FORWARD;
comment ================== 35056 ================= ;
procedure BACKWARD(X, P, Q, I0, NMAX, EPS, I);
value X, P, Q, I0, NMAX, EPS; integer NMAX; real X, P, Q, I0, EPS;
array I;
begin integer M, N, NU; real R, PQ, Y, LOGX;
array IAPPROX[0:NMAX];
I[0] := I0; if NMAX > 0 then
begin for N := 1 step 1 until NMAX do IAPPROX[N] := 0;
PQ := P + Q-1; LOGX := LN(X);
R := NMAX + (LN(EPS) + Q × LN(NMAX))/LOGX;
NU := ENTIER(R-Q × LN(R)/LOGX);
L1: N := NU; R := X;
L2: Y := (N + PQ) × X; R := Y/(Y + (N + P) × (1-R));
if N ≤ NMAX then I[N] := R; N := N-1;
if N ≥ 1 then goto L2; R := I0;
for N := 1 step 1 until NMAX do R := I[N] := I[N] × R;
for N := 1 step 1 until NMAX do
if ABS((I[N]-IAPPROX[N])/I[N]) > EPS then
begin for M := 1 step 1 until NMAX do
IAPPROX[M] := I[M]; NU := NU + 5; goto L1
end
end
end BACKWARD;
comment ================== 34150 ================= ;
Boolean procedure ZEROIN(X, Y, FX, TOLX);
real X, Y, FX, TOLX;
begin integer EXT;
real C, FC, B, FB, A, FA, D, FD, FDB, FDA, W, MB,
TOL, M, P, Q, DW;
DW := DWARF; B := X; FB := FX; A := X := Y; FA := FX;
INTERPOLATE: C := A; FC := FA; EXT := 0;
EXTRAPOLATE: if ABS(FC) < ABS(FB) then
begin if C ≠ A then begin D := A; FD := FA end;
A := B; FA := FB; B := X := C; FB := FC; C := A; FC := FA
end INTERCHANGE;
TOL := TOLX; M := (C + B) × 0.5; MB := M - B;
if ABS(MB) > TOL then
begin if EXT > 2 then W := MB else
begin TOL := TOL × SIGN(MB);
P := (B - A) × FB; if EXT ≤ 1 then
Q := FA - FB else
begin FDB := (FD - FB) / (D - B);
FDA := (FD - FA) / (D - A);
P := FDA × P; Q := FDB × FA - FDA × FB
end; if P < 0 then
begin P := -P; Q := -Q end;
W := if P < DW ∨ P ≤ Q × TOL then TOL else
if P < MB × Q then P / Q else MB
end; D := A; FD := FA; A := B; FA := FB;
X := B := B + W; FB := FX;
if (if FC ≥ 0 then FB ≥ 0 else FB ≤ 0) then
goto INTERPOLATE else
begin EXT := if W = MB then 0 else EXT + 1;
goto EXTRAPOLATE
end
end; Y := C;
ZEROIN := if FC ≥ 0 then FB ≤ 0 else FB ≥ 0
end ZEROIN;
comment ================== 34440 ================= ;
procedure MARQUARDT(M, N, PAR, G, V, FUNCT, JACOBIAN, IN, OUT);
value M, N; integer M, N; array PAR, G, V, IN, OUT;
Boolean procedure FUNCT; procedure JACOBIAN;
begin integer MAXFE, FE, IT, I, J, ERR;
real VV, WW, W, MU, RES, FPAR, FPARPRES, LAMBDA, LAMBDAMIN,
P, PW, RELTOLRES, ABSTOLRES;
array EM[0:7], VAL, B, BB, PARPRES[1:N], JAC[1:M, 1:N];
procedure MULCOL(L, U, S, T, A, B, X); code 31022;
procedure DUPVEC(L, U, S, A, B); code 31030;
real procedure VECVEC(L, U, S, A, B); code 34010;
real procedure MATVEC(L, U, S, A, B); code 34011;
real procedure TAMVEC(L, U, S, A, B); code 34012;
real procedure MATTAM(L, U, S, T, A, B); code 34015;
integer procedure QRISNGVALDEC(A, M, N, VAL, V, EM);
code 34273;
procedure LOCFUNCT(M, N, PAR, G);
integer M, N; array PAR, G;
begin FE := FE + 1; if FE ≥ MAXFE then ERR := 1 else
if ¬FUNCT(M, N, PAR, G) then ERR := 2;
if ERR ≠ 0 then goto EXIT
end LOCFUNCT;
VV := 10; W := 0.5; MU := 0.01;
WW := (if IN[6] < 10-7 then 10-8 else 10-1 × IN[6]);
EM[0] := EM[2] := EM[6] := IN[0]; EM[4] := 10 × N;
RELTOLRES := IN[3]; ABSTOLRES := IN[4]⭡2; MAXFE := IN[5];
ERR := 0; FE := IT := 1; P := FPAR := RES := 0;
PW := -LN(WW × IN[0])/2.30;
if ¬FUNCT(M, N, PAR, G) then
begin ERR := 3; goto ESCAPE end;
FPAR := VECVEC(1, M, 0, G, G); OUT[3] := SQRT(FPAR);
for IT := 1, IT + 1 while FPAR > ABSTOLRES ∧
RES > RELTOLRES × FPAR + ABSTOLRES do
begin JACOBIAN(M, N, PAR, G, JAC, LOCFUNCT);
I := QRISNGVALDEC(JAC, M, N, VAL, V, EM);
if IT = 1 then
LAMBDA := IN[6] × VECVEC(1, N, 0, VAL, VAL) else
if P = 0 then LAMBDA := LAMBDA × W else P := 0;
for I := 1 step 1 until N do
B[I] := VAL[I] × TAMVEC(1, M, I, JAC, G);
L: for I := 1 step 1 until N do
BB[I] := B[I]/(VAL[I] × VAL[I] + LAMBDA);
for I := 1 step 1 until N do
PARPRES[I] := PAR[I] - MATVEC(1, N, I, V, BB);
LOCFUNCT(M, N, PARPRES, G);
FPARPRES := VECVEC(1, M, 0, G, G);
RES := FPAR-FPARPRES;
if RES < MU × VECVEC(1, N, 0, B, BB) then
begin P := P + 1; LAMBDA := VV × LAMBDA;
if P = 1 then
begin LAMBDAMIN := WW × VECVEC(1, N, 0, VAL, VAL);
if LAMBDA < LAMBDAMIN then LAMBDA := LAMBDAMIN
end;
if P < PW then goto L else
begin ERR := 4;
goto EXIT
end;
end;
DUPVEC(1, N, 0, PAR, PARPRES);
FPAR := FPARPRES
end ITERATION;
EXIT:
for I := 1 step 1 until N do
MULCOL(1, N, I, I, JAC, V, 1/(VAL[I] + IN[0]));
for I := 1 step 1 until N do
for J := 1 step 1 until I do
V[I, J] := V[J, I] := MATTAM(1, N, I, J, JAC, JAC);
LAMBDA := LAMBDAMIN := VAL[1];
for I := 2 step 1 until N do
if VAL[I] > LAMBDA then LAMBDA := VAL[I] else
if VAL[I] < LAMBDAMIN then LAMBDAMIN := VAL[I];
OUT[7] := (LAMBDA/(LAMBDAMIN + IN[0]))⭡2;
OUT[2] := SQRT(FPAR);
OUT[6] := SQRT(RES + FPAR)-OUT[2];
ESCAPE:
OUT[4] := FE;
OUT[5] := IT-1;
OUT[1] := ERR
end MARQUARDT;
comment ================== 33135 ================= ;
procedure IMPEX (N, T0, TEND, Y0, DERIV, AVAILABLE, H0, HMAX,
PRESCH, EPS, WEIGHTS, UPDATE, FAIL, CONTROL);
value N;
integer N;
real T0, TEND, H0, HMAX, EPS;
Boolean PRESCH, FAIL;
array Y0, WEIGHTS;
Boolean procedure AVAILABLE;
procedure DERIV, UPDATE, CONTROL;
begin integer I, K, ECI;
real T, T1, T2, T3, TP, H, H2, HNEW, ALF, LQ;
array Y, Z, S1, S2, S3, U1, U3, W1, W2, W3, EHR[1:N], R, RF[1:5, 1:N],
ERR[1:3], A1, A2[1:N, 1:N];
integer array PS1, PS2[1:N];
Boolean START, TWO, HALV;
procedure INIVEC(L, U, A, X); code 31010;
procedure INIMAT(LR, UR, LC, UC, A, X); code 31011;
procedure MULVEC(L, U, SHIFT, A, B, X); code 31020;
procedure MULROW(L, U, I, J, A, B, X); code 31021;
procedure DUPVEC(L, U, SHIFT, A, B); code 31030;
procedure DUPROWVEC(L, U, I, A, B); code 31032;
procedure DUPMAT(L, U, I, J, A, B); code 31035;
real procedure VECVEC(L, U, SHIFT, A, B); code 34010;
real procedure MATVEC(L, U, I, A, B); code 34011;
real procedure MATMAT(L, U, I, J, A, B); code 34013;
procedure ELMVEC(L, U, SHIFT, A, B, X); code 34020;
procedure ELMROW(L, U, I, J, A, B, X); code 34024;
procedure DEC(A, N, AUX, P); code 34300;
procedure SOL(A, N, P, B); code 34051;
procedure DFDY(T, Y, A); real T; array Y, A;
begin integer I, J; real SL; array F1, F2[1:N];
DERIV(T, Y, F1, N);
for I := 1 step 1 until N do
begin
SL := 10-6 × Y[I]; if ABS(SL) < 10-6 then SL := 10-6;
Y[I] := Y[I] + SL; DERIV(T, Y, F2, N);
for J := 1 step 1 until N do
A[J, I] := (F2[J]-F1[J])/SL;
Y[I] := Y[I]-SL;
end
end DFDY;
procedure STARTV(Y, T); value T; real T; array Y;
begin real A, B, C;
A := (T-T1)/(T1-T2); B := (T-T2)/(T1-T3);
C := (T-T1)/(T2-T3) × B; B := A × B;
A := 1 + A + B; B := A + C-1;
MULVEC(1, N, 0, Y, S1, A); ELMVEC(1, N, 0, Y, S2, -B);
ELMVEC(1, N, 0, Y, S3, C)
end STARTV;
procedure ITERATE(Z, Y, A, H, T, WEIGHTS, FAIL, PS);
array Z, Y, A, WEIGHTS; real H, T; label FAIL;
integer array PS;
begin integer IT, LIT; real MAX, MAX1, CONV; array DZ, F1[1:N];
for I := 1 step 1 until N do Z[I] := (Z[I] + Y[I])/2;
IT := LIT := 1; CONV := 1;
ATER: DERIV(T, Z, F1, N);
for I := 1 step 1 until N do
F1[I] := DZ[I] := Z[I]-H × F1[I]/2-Y[I];
SOL(A, N, PS, DZ);
ELMVEC(1, N, 0, Z, DZ, -1);
MAX := 0;
for I := 1 step 1 until N do
MAX := MAX + (WEIGHTS[I] × DZ[I])⭡2;
MAX := SQRT(MAX);
if MAX × CONV < EPS/10 then goto OUT;
IT := IT + 1; if IT = 2 then goto ASS;
CONV := MAX/MAX1;
if CONV > .2 then
begin if LIT = 0 then goto FAIL;
LIT := 0; CONV := 1; IT := 1;
RECOMP(A, H, T, Z, FAIL, PS);
end;
ASS: MAX1 := MAX;
goto ATER;
OUT: for I := 1 step 1 until N do Z[I] := 2 × Z[I]-Y[I];
end ITERATE;
procedure RECOMP(A, H, T, Y, FAIL, PS);
real H, T; array A, Y; label FAIL; integer array PS;
begin real SL; array AUX[1:3];
SL := H/2;
if ¬AVAILABLE(T, Y, A, N) then DFDY(T, Y, A);
for I := 1 step 1 until N do
begin MULROW(1, N, I, I, A, A, -SL); A[I, I] := 1 + A[I, I]
end;
AUX[2] := 10-14;
DEC(A, N, AUX, PS);
if AUX[3] < N then goto FAIL
end RECOMP;
procedure INITIALIZATION;
begin H2 := HNEW; H := H2/2;
DUPVEC(1, N, 0, S1, Y0); DUPVEC(1, N, 0, S2, Y0); DUPVEC(1, N, 0, S3, Y0);
DUPVEC(1, N, 0, W1, Y0); DUPROWVEC(1, N, 1, R, Y0);
INIVEC(1, N, U1, 0); INIVEC(1, N, W2, 0);
INIMAT(2, 5, 1, N, R, 0); INIMAT(1, 5, 1, N, RF, 0);
T := T1 := T0; T2 := T0-2 × H-106; T3 := 2 × T2 + 1;
RECOMP(A1, H, T, S1, MISS, PS1); RECOMP(A2, H2, T, W1, MISS, PS2);
end
procedure ONE LARGE STEP;
begin STARTV(Z, T + H);
ITERATE(Z, S1, A1, H, T + H/2, WEIGHTS, MISS, PS1);
DUPVEC(1, N, 0, Y, Z);
STARTV(Z, T + H2);
ITERATE(Z, Y, A1, H, T + 3 × H/2, WEIGHTS, MISS, PS1);
DUPVEC(1, N, 0, U3, U1); DUPVEC(1, N, 0, U1, Y);
DUPVEC(1, N, 0, S3, S2); DUPVEC(1, N, 0, S2, S1);
DUPVEC(1, N, 0, S1, Z);
ELMVEC(1, N, 0, Z, W1, 1); ELMVEC(1, N, 0, Z, S2, -1);
ITERATE(Z, W1, A2, H2, T + H, WEIGHTS, MISS, PS2);
T3 := T2; T2 := T1; T1 := T + H2;
DUPVEC(1, N, 0, W3, W2); DUPVEC(1, N, 0, W2, W1); DUPVEC(1, N, 0, W1, Z);
end;
procedure CHANGE OF INFORMATION;
begin real ALF1, C1, C2, C3; array KOF[2:4, 2:4], E, D[1:4];
C1 := HNEW/H2; C2 := C1 × C1; C3 := C2 × C1;
KOF[2, 2] := C1; KOF[2, 3] := (C1-C2)/2; KOF[2, 4] := C3/6-C2/2 + C1/3;
KOF[3, 3] := C2; KOF[3, 4] := C2-C3; KOF[4, 4] := C3;
for I := 1 step 1 until N do
U1[I] := R[2, I] + R[3, I]/2 + R[4, I]/3;
ALF1 := MATVEC(1, N, 1, RF, U1)/VECVEC(1, N, 0, U1, U1);
ALF := (ALF + ALF1) × C1;
for I := 1 step 1 until N do
begin
E[1] := RF[1, I]-ALF1 × U1[I];
E[2] := RF[2, I]-ALF1 × 2 × R[3, I];
E[3] := RF[3, I]-ALF1 × 4 × R[4, I];
E[4] := RF[4, I];
D[1] := R[1, I]; RF[1, I] := E[1] := E[1] × C2;
for K := 2 step 1 until 4 do
begin R[K, I] := D[K] := MATMAT(K, 4, K, I, KOF, R);
RF[K, I] := E[K] := C2 × MATVEC(K, 4, K, KOF, E)
end K;
S1[I] := D[1] + E[1]; W1[I] := D[1] + 4 × E[1];
S2[I] := S1[I]-(D[2] + E[2]/2);
S3[I] := S2[I]-(D[2] + E[2]) + (D[3] + E[3]/2);
end I;
T3 := T-HNEW; T2 := T-HNEW/2; T1 := T;
H2 := HNEW; H := H2/2; ERR[1] := 0;
if HALV then
begin DUPVEC(1, N, 0, PS2, PS1); DUPMAT(1, N, 1, N, A2, A1) end;
if TWO then
begin DUPVEC(1, N, 0, PS1, PS2); DUPMAT(1, N, 1, N, A1, A2)
end else RECOMP(A1, HNEW/2, T, S1, MISS, PS1);
if ¬HALV then RECOMP(A2, HNEW, T, W1, MISS, PS2);
end;
procedure BACKWARD DIFFERENCES;
for I := 1 step 1 until N do
begin real B0, B1, B2, B3;
B1 := (U1[I] + 2 × S2[I] + U3[I])/4;
B2 := (W1[I] + 2 × W2[I] + W3[I])/4;
B3 := (S3[I] + 2 × U3[I] + S2[I])/4;
B2 := (B2-B1)/3; B0 := B1-B2;
B2 := B2-(S1[I]-2 × S2[I] + S3[I])/16;
B1 := 2 × B3-(B2 + RF[1, I])-(B0 + R[1, I])/2;
B3 := 0;
for K := 1 step 1 until 4 do
begin B1 := B1-B3; B3 := R[K, I]; R[K, I] := B0; B0 := B0-B1
end; R[5, I] := B0;
for K := 1 step 1 until 4 do
begin B3 := RF[K, I]; RF[K, I] := B2; B2 := B2-B3 end;
RF[5, I] := B2;
end;
procedure ERROR ESTIMATES;
begin real C0, C1, C2, C3, B0, B1, B2, B3, W, SL1, SN, LR;
C0 := C1 := C2 := C3 := 0;
for I := 1 step 1 until N do
begin W := WEIGHTS[I]⭡2;
B0 := RF[4, I]/36; C0 := C0 + B0 × B0 × W; LR := ABS(B0);
B1 := RF[1, I] + ALF × R[2, I]; C1 := C1 + B1 × B1 × W;
B2 := RF[3, I]; C2 := C2 + B2 × B2 × W;
SL1 := ABS(RF[1, I]-RF[2, I]);
SN := if SL1 < 10-10 then 1 else ABS(RF[1, I]-R[4, I]/6)/SL1;
if SN > 1 then SN := 1;
if START then begin SN := SN⭡4; LR := LR × 4 end;
EHR[I] := B3 := SN × EHR[I] + LR; C3 := C3 + B3 × B3 × W;
end I;
B0 := ERR[1];
ERR[1] := B1 := SQRT(C0); ERR[2] := SQRT(C1);
ERR[3] := SQRT(C3) + SQRT(C2)/2;
LQ := EPS/(if B0 < B1 then B1 else B0);
if B0 < B1 ∧ LQ ≥ 80 then LQ := 10;
end;
procedure REJECT;
if START then
begin HNEW := LQ⭡(1/5) × H/2; goto INIT
end else
begin for K := 1, 2, 3, 4, 1, 2, 3 do ELMROW(1, N, K, K + 1, R, R, -1);
for K := 1, 2, 3, 4 do ELMROW(1, N, K, K + 1, RF, RF, -1);
T := T-H2; HALV := true; HNEW := H; goto MSTP
end;
procedure STEPSIZE;
if LQ < 2 then
begin HALV := true; HNEW := H end else
begin if LQ > 80 then
HNEW := (if LQ > 5120 then (LQ/5)⭡(1/5) else 2) × H2;
if HNEW > HMAX then HNEW := HMAX;
if TEND > T ∧ TEND-T < HNEW then HNEW := TEND-T;
TWO := HNEW = 2 × H2;
end;
if PRESCH then H := H0 else
begin if H0 > HMAX then H := HMAX else H := H0;
if H > (TEND-T0)/4 then H := (TEND-T0)/4;
end;
HNEW := H;
ALF := 0; T := TP := T0;
INIVEC(1, 3, ERR, 0); INIVEC(1, N, EHR, 0);
DUPROWVEC(1, N, 1, R, Y0);
CONTROL(TP, T, H, HNEW, R, ERR, N);
INIT: INITIALIZATION; START := true;
for ECI := 0, 1, 2, 3 do
begin ONE LARGE STEP; T := T + H2;
if ECI > 0 then
begin BACKWARD DIFFERENCES; UPDATE(WEIGHTS, S2, N) end
end;
ECI := 4;
MSTP: if HNEW ≠ H2 then
begin ECI := 1; CHANGE OF INFORMATION;
ONE LARGE STEP; T := T + H2; ECI := 2;
end;
ONE LARGE STEP;
BACKWARD DIFFERENCES;
UPDATE(WEIGHTS, S2, N);
ERROR ESTIMATES;
if ECI < 4 ∧ LQ > 80 then LQ := 20;
HALV := TWO := false;
if PRESCH then goto TRYCK;
if LQ < 1 then REJECT else STEPSIZE;
TRYCK: if TP ≤ T then CONTROL(TP, T, H, HNEW, R, ERR, N);
if START then START := false;
if HNEW = H2 then T := T + H2; ECI := ECI + 1;
if T < TEND + H2 then goto MSTP else goto END;
MISS: FAIL := PRESCH;
if ¬FAIL then
begin if ECI > 1 then T := T-H2;
HALV := TWO := false; HNEW := H2/2;
if START then goto INIT else goto TRYCK
end;
END:
end IMPEX;
comment ================== 35021 ================= ;
procedure ERRORFUNCTION(X, ERF, ERFC);
value X; real X, ERF, ERFC;
if X > 26 then begin ERF := 1; ERFC := 0 end else
if X < -5.5 then begin ERF := -1; ERFC := 2 end else
begin real ABSX, C, P, Q;
real procedure NONEXPERFC(X); code 35022;
ABSX := ABS(X);
if ABSX ≤ 0.5 then
begin C := X × X; P := ((-0.35609 84370 1815410-1 × C +
0.69963 83488 6191410+1) × C + 0.21979 26161 8294210+2) × C +
0.24266 79552 3053210+3;
Q := ((C +
0.15082 79763 0407810+2) × C + 0.91164 90540 4514910+2) × C +
0.21505 88758 6986110+3;
ERF := X × P / Q; ERFC := 1 - ERF
end else
begin ERFC := EXP(-X × X) × NONEXPERFC(ABSX);
ERF := 1 - ERFC;
if X < 0 then
begin ERF := -ERF; ERFC := 2 - ERFC end
end
end ERRORFUNCTION;
comment ================== 35022 ================= ;
real procedure NONEXPERFC(X); value X; real X;
begin real ABSX, ERF, ERFC, C, P, Q;
procedure ERRORFUNCTION(X, ERF, ERFC); code 35021;
ABSX := ABS(X);
if ABSX ≤ 0.5 then
begin ERRORFUNCTION(X, ERF, ERFC);
NONEXPERFC := EXP(X × X) × ERFC
end else
if ABSX < 4 then
begin C := ABSX; P := ((((((-0.13686 48573 8271710-6 × C +
0.56419 55174 7897410+0) × C + 0.72117 58250 8830910+1) × C +
0.43162 22722 2056710+2) × C + 0.15298 92850 4694010+3) × C +
0.33932 08167 3434410+3) × C + 0.45191 89537 1187310+3) × C +
0.30045 92610 2016210+3;
Q := ((((((C +
0.12782 72731 9629410+2) × C + 0.77000 15293 5229510+2) × C +
0.27758 54447 4398810+3) × C + 0.63898 02644 6563110+3) × C +
0.93135 40948 5061010+3) × C + 0.79095 09253 2789810+3) × C +
0.30045 92609 5698310+3;
NONEXPERFC := if X > 0 then P / Q else
EXP(X × X) × 2 - P / Q
end else
begin C := 1 / X / X; P := (((0.22319 24597 3418510-1 × C +
0.27866 13086 0964810-0) × C + 0.22695 65935 3968710-0) × C +
0.49473 09106 2325110-1) × C + 0.29961 07077 0354210-2;
Q := (((C +
0.19873 32018 1713510+1) × C + 0.10516 75107 0679310+1) × C +
0.19130 89261 0783010+0) × C + 0.10620 92305 2846810-1;
C := (C × (-P) / Q + 0.56418 95835 47756) / ABSX;
NONEXPERFC := if X > 0 then C else EXP(X × X) × 2 - C
end
end NONEXPERFC;
comment ================== 35027 ================= ;
procedure FRESNEL(X, C, S); value X; real X, C, S;
begin real ABSX, X3, X4, A, P, Q, F, G, C1, S1;
procedure FG(X, F, G); code 35028;
ABSX := ABS(X);
if ABSX ≤ 1.2 then
begin A := X × X; X3 := A × X; X4 := A × A;
P := (((5.47711 38568 268710-6 × X4 - 5.28079 65137 262310-4)
× X4 + 1.76193 95254 349110-2) × X4 - 1.99460 89882 618410-1)
× X4 + 1;
Q := (((1.18938 90142 287610-7 × X4 + 1.55237 88527 699410-5)
× X4 + 1.09957 21502 564210-3) × X4 + 4.72792 11201 045310-2)
× X4 + 1;
C := X × P / Q;
P := (((6.71748 46662 514110-7 × X4 - 8.45557 28435 277710-5)
× X4 + 3.87782 12346 368310-3) × X4 - 7.07489 91514 452310-2)
× X4 + 5.23598 77559 829910-1;
Q := (((5.95281 22767 841010-8 × X4 + 9.62690 87593 903410-6)
× X4 + 8.17091 94215 213410-4) × X4 + 4.11223 15114 238410-2)
× X4 + 1;
S := X3 × P / Q
end else
if ABSX ≤ 1.6 then
begin A := X × X; X3 := A × X; X4 := A × A;
P := ((((-5.68293 31012 187110-8 × X4 + 1.02365 43505 610610-5)
× X4 - 6.71376 03469 492210-4) × X4 + 1.91870 27943 174710-2)
× X4 - 2.07073 36033 532410-1) × X4 + 1.00000 00000 011110+0;
Q := ((((4.41701 37406 501010-10 × X4 + 8.77945 37789 236910-8)
× X4 + 1.01344 63086 674910-5) × X4 + 7.88905 24505 236010-4)
× X4 + 3.96667 49695 232310-2) × X4 + 1;
C := X × P / Q;
P := ((((-5.76765 81559 308910-9 × X4 + 1.28531 04374 272510-6)
× X4 - 1.09540 02391 143510-4) × X4 + 4.30730 52650 436710-3)
× X4 - 7.37766 91401 019110-2) × X4 + 5.23598 77559 834410-1;
Q := ((((2.05539 12445 858010-10 × X4 + 5.03090 58124 661210-8)
× X4 + 6.87086 26571 862010-6) × X4 + 6.18224 62019 547310-4)
× X4 + 3.53398 34276 747210-2) × X4 + 1;
S := X3 × P / Q
end else
if ABSX < 1015 then
begin FG(X, F, G);
A := X × X;
A := (A - ENTIER(A / 4) × 4) × 1.57079 63267 9490;
C1 := COS(A); S1 := SIN(A);
A := if X < 0 then -0.5 else 0.5;
C := F × S1 - G × C1 + A;
S := -F × C1 - G × S1 + A
end else C := S := SIGN(X) × 0.5
end FRESNEL;
comment ================== 35028 ================= ;
procedure FG(X, F, G); value X; real X, F, G;
begin real ABSX, C, S, C1, S1, A, XINV, X3INV, C4, P, Q;
procedure FRESNEL(X, C, S); code 35027;
ABSX := ABS(X);
if ABSX ≤ 1.6 then
begin FRESNEL(X, C, S);
A := X × X × 1.57079 63267 9490; C1 := COS(A); S1 := SIN(A);
A := if X < 0 then -0.5 else 0.5;
P := A - C; Q := A - S;
F := Q × C1 - P × S1;
G := P × C1 + Q × S1
end else
if ABSX ≤ 1.9 then
begin XINV := 1 / X; A := XINV × XINV;
X3INV := A × XINV; C4 := A × A;
P := (((1.35304 23554 038810+1 × C4 + 6.98534 26160 102110+1)
× C4 + 4.80340 65557 792510+1) × C4 + 8.03588 12280 394210+0)
× C4 + 3.18309 26850 490610-1;
Q := (((6.55630 64008 391610+1 × C4 + 2.49561 99380 517210+2)
× C4 + 1.57611 00558 012310+2) × C4 + 2.55491 61843 579510+1)
× C4 + 1;
F := XINV × P / Q;
P := ((((2.05421 43249 850110+1 × C4 + 1.96232 03797 166310+2)
× C4 + 1.99182 81867 890310+2) × C4 + 5.31122 81348 098910+1)
× C4 + 4.44533 82755 051210+0) × C4 + 1.01320 61881 027510-1;
Q := ((((1.01379 48339 600310+3 × C4 + 3.48112 14785 654510+3)
× C4 + 2.54473 13318 182210+3) × C4 + 5.83590 57571 642910+2)
× C4 + 4.53925 01967 368910+1) × C4 + 1;
G := X3INV × P / Q
end else
if ABSX ≤ 2.4 then
begin XINV := 1 / X; A := XINV × XINV;
X3INV := A × XINV; C4 := A × A;
P := ((((7.17703 24936 514010+2 × C4 + 3.09145 16157 443010+3)
× C4 + 1.93007 64078 671610+3) × C4 + 3.39837 13492 698410+2)
× C4 + 1.95883 94102 196910+1) × C4 + 3.18309 88182 201710-1;
Q := ((((3.36121 69918 055110+3 × C4 + 1.09334 24898 880910+4)
× C4 + 6.33747 15585 114410+3) × C4 + 1.08535 06750 065010+3)
× C4 + 6.18427 13817 288710+1) × C4 + 1;
F := XINV × P / Q;
P := ((((3.13330 16306 875610+2 × C4 + 1.59268 00608 535410+3)
× C4 + 9.08311 74952 959410+2) × C4 + 1.40959 61791 131610+2)
× C4 + 7.11205 00178 978310+0) × C4 + 1.01321 16176 180510-1;
Q := ((((1.15149 83237 626110+4 × C4 + 2.41315 56721 337010+4)
× C4 + 1.06729 67803 058110+4) × C4 + 1.49051 92279 732910+3)
× C4 + 7.17128 59693 930210+1) × C4 + 1;
G := X3INV × P / Q
end else
begin XINV := 1 / X; A := XINV × XINV;
X3INV := A × XINV; C4 := A × A;
P := ((((2.61294 75322 514210+4 × C4 + 6.13547 11361 470010+4)
× C4 + 1.34922 02817 185710+4) × C4 + 8.16343 40178 437510+2)
× C4 + 1.64797 71284 124610+1) × C4 + 9.67546 03296 709010-2;
Q := ((((1.37012 36481 722610+6 × C4 + 1.00105 47890 079110+6)
× C4 + 1.65946 46262 185310+5) × C4 + 9.01827 59623 152410+3)
× C4 + 1.73871 69067 364910+2) × C4 + 1;
F := (C4 × (-P) / Q + 0.31830 98861 83791) × XINV;
P := (((((1.72590 22465 483710+6 × C4 + 6.66907 06166 863610+6)
× C4 + 1.77758 95083 803010+6) × C4 + 1.35678 86781 375610+5)
× C4 + 3.87754 14174 637810+3) × C4 + 4.31710 15782 335810+1)
× C4 + 1.53989 73381 976910-1;
Q := (((((1.40622 44112 358010+8 × C4 + 9.38695 86253 163510+7)
× C4 + 1.62095 60050 023210+7) × C4 + 1.02878 69305 668810+6)
× C4 + 2.69183 18039 624310+4) × C4 + 2.86733 19497 589910+2)
× C4 + 1;
G := (C4 × (-P) / Q + 0.10132 11836 42338) × X3INV
end
end FG;
comment ================== 34453 ================= ;
Boolean procedure ZEROINDER(X, Y, FX, DFX, TOLX);
real X, Y, FX, DFX, TOLX;
begin integer EXT;
real B, FB, DFB, A, FA, DFA, C, FC, DFC, D, W, MB,
TOL, M, P, Q, DW;
real procedure DWARF; code 30003;
DW := DWARF;
B := X; FB := FX; DFB := DFX; A := X := Y; FA := FX; DFA := DFX;
INTERPOLATE: C := A; FC := FA; DFC := DFA; EXT := 0;
EXTRAPOLATE: if ABS(FC) < ABS(FB) then
begin A := B; FA := FB; DFA := DFB; B := X := C; FB := FC;
DFB := DFC; C := A; FC := FA; DFC := DFA
end INTERCHANGE;
TOL := TOLX; M := (C + B) × 0.5; MB := M - B;
if ABS(MB) > TOL then
begin if EXT > 2 then W := MB else
begin TOL := TOL × SIGN(MB);
D := if EXT = 2 then DFA else (FB - FA) / (B - A);
P := FB × D × (B - A);
Q := FA × DFB - FB × D;
if P < 0 then begin P := -P; Q := -Q end;
W := if P < DW ∨ P ≤ Q × TOL then TOL else
if P < MB × Q then P / Q else MB;
end; A := B; FA := FB; DFA := DFB;
X := B := B + W; FB := FX; DFB := DFX;
if (if FC ≥ 0 then FB ≥ 0 else FB ≤ 0) then
goto INTERPOLATE else
begin EXT := if W = MB then 0 else EXT + 1;
goto EXTRAPOLATE
end
end; Y := C;
ZEROINDER := if FC ≥ 0 then FB ≤ 0 else FB ≥ 0
end ZEROINDER;
comment ================== 34432 ================= ;
procedure PRAXIS(N, X, FUNCT, IN, OUT);
value N; integer N;
array X, IN, OUT;
real procedure FUNCT;
begin
comment THIS PROCEDURE MINIMIZES FUNCT(N, X), WITH THE
PRINCIPAL AXIS METHOD (SEE BRENT, R.P, 1973, ALGORITHMS
FOR MINIMIZATION WITHOUT DERIVATIVES, CH.7);
procedure INIVEC(L, U, A, X); code 31010;
procedure INIMAT(L, U, K, V, A, X); code 31011;
procedure DUPVEC(L, U, K, A, X); code 31030;
procedure DUPMAT(L, U, K, V, A, B); code 31035;
procedure DUPCOLVEC(L, U, K, A, B); code 31034;
procedure MULROW(L, U, I, J, A, B, X); code 31021;
procedure MULCOL(L, U, I, J, A, B, X); code 31022;
real procedure VECVEC(L, U, S, A, B); code 34010;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
real procedure MATTAM(L, U, I, J, A, B); code 34015;
procedure ICHROWCOL(L, U, I, J, A); code 34033;
procedure ELMVECCOL(L, U, I, A, B, X); code 34021;
integer procedure QRISNGVALDEC(A, M, N, VAL, V, EM); code 34273;
procedure SETRANDOM(X); code 11014;
real procedure RANDOM; code 11015;
real procedure DWARF; code 30003;
procedure SORT;
begin integer I, J, K; real S;
for I := 1 step 1 until N - 1 do
begin K := I; S := D[I];
for J := I + 1 step 1 until N do if D[J] > S then
begin K := J; S := D[J] end;
if K > I then
begin D[K] := D[I]; D[I] := S;
for J := 1 step 1 until N do
begin S := V[J, I]; V[J, I] := V[J, K]; V[J, K] := S
end
end
end
end SORT;
procedure MIN(J, NITS, D2, X1, F1, FK); value J, NITS, FK;
integer J, NITS; real D2, X1, F1; Boolean FK;
begin
real procedure FLIN(L); value L; real L;
begin integer I; array T[1:N];
if J > 0 then
begin for I := 1 step 1 until N do
T[I] := X[I] + L × V[I, J]
end else
begin comment SEARCH ALONG PARABOLIC SPACE CURVE;
QA := L × (L - QD1) / (QD0 × (QD0 + QD1));
QB := (L + QD0) × (QD1 - L) /(QD0 × QD1);
QC := L × (L + QD0) / (QD1 × (QD0 + QD1));
for I := 1 step 1 until N do
T[I] := QA × Q0[I] + QB × X[I] + QC × Q1[I]
end;
NF := NF + 1; FLIN := FUNCT(N, T)
end FLIN;
integer K; Boolean DZ;
real X2, XM, F0, F2, FM, D1, T2, S, SF1, SX1;
SF1 := F1; SX1 := X1;
K := 0; XM := 0; F0 := FM := FX; DZ := D2 < RELTOL;
S := SQRT(VECVEC(1, N, 0, X, X));
T2 := M4 × SQRT(ABS(FX) / (if DZ then DMIN else D2)
+ S × LDT) + M2 × LDT; S := S × M4 + ABSTOL;
if DZ ∧ T2 > S then T2 := S;
if T2 < SMALL then T2 := SMALL;
if T2 > 0.01 × H then T2 := 0.01 × H;
if FK ∧ F1 ≤ FM then
begin XM := X1; FM := F1 end;
if ¬FK ∨ ABS(X1) < T2 then
begin X1 := if X1 > 0 then T2 else -T2;
F1 := FLIN(X1)
end;
if F1 ≤ FM then
begin XM := X1; FM := F1 end;
L0: if DZ then
begin comment EVALUATE FLIN AT ANOTHER POINT
AND ESTIMATE THE SECOND DERIVATIVE;
X2 := if F0 < F1 then -X1 else X1 × 2;
F2 := FLIN(X2); if F2 ≤ FM then
begin XM := X2; FM := F2 end;
D2 := (X2 × (F1-F0)-X1 × (F2-F0))/(X1 × X2 × (X1-X2))
end;
comment ESTIMATE FIRST DERIVATIVE AT 0;
D1 := (F1-F0)/X1-X1 × D2; DZ := true;
X2 := if D2 ≤ SMALL then
(if D1 < 0 then H else -H)
else -0.5 × D1/D2;
if ABS(X2) > H then X2 := if X2 > 0 then H else -H;
L1: F2 := FLIN(X2);
if K < NITS ∧ F2 > F0 then
begin K := K + 1;
if F0 < F1 ∧ X1 × X2 > 0 then goto L0;
X2 := 0.5 × X2; goto L1
end;
NL := NL + 1;
if F2 > FM then X2 := XM else FM := F2;
D2 := if ABS(X2 × (X2-X1)) > SMALL then
(X2 × (F1-F0)-X1 × (FM-F0))/(X1 × X2 × (X1-X2))
else if K > 0 then 0 else D2;
if D2 ≤ SMALL then D2 := SMALL;
X1 := X2; FX := FM;
if SF1 < FX then
begin FX := SF1; X1 := SX1 end;
if J > 0 then ELMVECCOL(1, N, J, X, V, X1)
end MIN;
procedure QUAD;
begin integer I; real L, S;
S := FX; FX := QF1; QF1 := S; QD1 := 0;
for I := 1 step 1 until N do
begin S := X[I]; X[I] := L := Q1[I]; Q1[I] := S;
QD1 := QD1 + (S - L) ⭡ 2
end;
L := QD1 := SQRT(QD1); S := 0;
if (QD0 × QD1 > DWARF) ∧ NL ≥ 3 × N × N then
begin MIN(0, 2, S, L, QF1, true);
QA := L × (L-QD1)/(QD0 × (QD0 + QD1));
QB := (L + QD0) × (QD1-L)/(QD0 × QD1);
QC := L × (L + QD0)/(QD1 × (QD0 + QD1))
end else
begin FX := QF1; QA := QB := 0; QC := 1 end;
QD0 := QD1; for I := 1 step 1 until N do
begin S := Q0[I]; Q0[I] := X[I];
X[I] := QA × S + QB × X[I] + QC × Q1[I]
end
end QUAD;
Boolean ILLC;
integer I, J, K, K2, NL, MAXF, NF, KL, KT, KTM;
real S, SL, DN, DMIN, FX, F1, LDS, LDT, SF, DF, QF1, QD0,
QD1, QA, QB, QC, M2, M4, SMALL, VSMALL, LARGE, VLARGE, SCBD,
LDFAC, T2, MACHEPS, RELTOL, ABSTOL, H;
array V[1:N, 1:N], D, Y, Z, Q0, Q1[1:N];
MACHEPS := IN[0]; RELTOL := IN[1]; ABSTOL := IN[2]; MAXF := IN[5];
H := IN[6]; SCBD := IN[7]; KTM := IN[8]; ILLC := IN[9] < 0;
SMALL := MACHEPS ⭡ 2; VSMALL := SMALL ⭡ 2;
LARGE := 1/SMALL; VLARGE := 1/VSMALL;
M2 := RELTOL; M4 := SQRT(M2); SETRANDOM(0.5);
LDFAC := if ILLC then 0.1 else 0.01;
KT := NL := 0; NF := 1; OUT[3] := QF1 := FX := FUNCT(N, X);
ABSTOL := T2 := SMALL + ABS(ABSTOL); DMIN := SMALL;
if H < ABSTOL × 100 then H := ABSTOL × 100; LDT := H;
INIMAT(1, N, 1, N, V, 0);
for I := 1 step 1 until N do V[I, I] := 1;
D[1] := QD0 := 0; DUPVEC(1, N, 0, Q1, X);
INIVEC(1, N, Q0, 0);
comment MAIN LOOP;
L0: SF := D[1]; D[1] := S := 0;
MIN(1, 2, D[1], S, FX, false);
if S ≤ 0 then MULCOL(1, N, 1, 1, V, V, -1);
if SF ≤ 0.9 × D[1] ∨ 0.9 × SF ≥ D[1] then
INIVEC(2, N, D, 0);
for K := 2 step 1 until N do
begin DUPVEC(1, N, 0, Y, X); SF := FX;
ILLC := ILLC ∨ KT > 0;
L1: KL := K; DF := 0; if ILLC then
begin comment RANDOM STOP TO GET OFF
RESULTION VALLEY;
for I := 1 step 1 until N do
begin S := Z[I] := (0.1 × LDT + T2 × 10⭡KT)
× (RANDOM-0.5);
ELMVECCOL(1, N, I, X, V, S)
end;
FX := FUNCT(N, X); NF := NF + 1
end;
for K2 := K step 1 until N do
begin SL := FX; S := 0;
MIN (K2, 2, D[K2], S, FX, false);
S := if ILLC then D[K2] × (S + Z[K2]) ⭡ 2
else SL-FX; if DF < S then
begin DF := S; KL := K2 end;
end;
if ¬ILLC ∧ DF < ABS(100 × MACHEPS × FX) then
begin ILLC := true; goto L1 end;
for K2 := 1 step 1 until K-1 do
begin S := 0; MIN(K2, 2, D[K2], S, FX, false) end;
F1 := FX; FX := SF; LDS := 0;
for I := 1 step 1 until N do
begin SL := X[I]; X[I] := Y[I]; SL := Y[I] := SL - Y[I];
LDS := LDS + SL × SL
end; LDS := SQRT(LDS);
if LDS > SMALL then
begin for I := KL - 1 step -1 until K do
begin for J := 1 step 1 until N do
V[J, I + 1] := V[J, I]; D[I + 1] := D[I]
end;
D[K] := 0; DUPCOLVEC(1, N, K, V, Y);
MULCOL(1, N, K, K, V, V, 1 / LDS);
MIN(K, 4, D[K], LDS, F1, true); if LDS ≤ 0 then
begin LDS := LDS; MULCOL(1, N, K, K, V, V, -1) end
end;
LDT := LDFAC × LDT; if LDT < LDS then LDT := LDS;
T2 := M2 × SQRT(VECVEC(1, N, 0, X, X)) + ABSTOL;
KT := if LDT > 0.5 × T2 then 0 else KT + 1;
if KT > KTM then begin OUT[1] := 0; goto L2 end
end;
QUAD;
DN := 0; for I := 1 step 1 until N do
begin D[I] := 1/SQRT(D[I]);
if DN < D[I] then DN := D[I]
end;
for J := 1 step 1 until N do
begin S := D[J]/DN; MULCOL(1, N, J, J, V, V, S) end;
if SCBD > 1 then
begin S := VLARGE; for I := 1 step 1 until N do
begin SL := Z[I] := SQRT(MATTAM(1, N, I, I, V, V));
if SL < M4 then Z[I] := M4;
if S > SL then S := SL
end;
for I := 1 step 1 until N do
begin SL := S/Z[I]; Z[I] := 1/SL;
if Z[I] > SCBD then
begin SL := 1/SCBD; Z[I] := SCBD end;
MULROW(1, N, I, I, V, V, SL)
end
end;
for I := 1 step 1 until N do
ICHROWCOL(I + 1, N, I, I, V);
begin array A[1:N, 1:N], EM[0:7];
EM[0] := EM[2] := MACHEPS;
EM[4] := 10 × N; EM[6] := VSMALL;
DUPMAT(1, N, 1, N, A, V);
if QRISNGVALDEC(A, N, N, D, V, EM) ≠ 0 then
begin OUT[1] := 2; goto L2 end;
end;
if SCBD > 1 then
begin for I := 1 step 1 until N do
MULROW(1, N, I, I, V, V, Z[I]);
for I := 1 step 1 until N do
begin S := SQRT(TAMMAT(1, N, I, I, V, V));
D[I] := S × D[I]; S := 1/S;
MULCOL(1, N, I, I, V, V, S)
end
end;
for I := 1 step 1 until N do
begin S := DN × D[I];
D[I] := if S > LARGE then VSMALL else
if S < SMALL then VLARGE else S ⭡ (-2)
end;
SORT;
DMIN := D[N]; if DMIN < SMALL then DMIN := SMALL;
ILLC := (M2 × D[1]) > DMIN;
if NF < MAXF then goto L0 else OUT[1] := 1;
L2: OUT[2] := FX;
OUT[4] := NF; OUT[5] := NL; OUT[6] := LDT
end PRAXIS;
comment ================== 31061 ================= ;
real procedure INFNRMVEC(L, U, K, A); value L, U;
integer L, U, K; array A;
begin real R, MAX;
MAX := 0; K := L;
for L := L step 1 until U do
begin R := ABS(A[L]); if R > MAX then
begin MAX := R; K := L end
end;
INFNRMVEC := MAX
end INFNRMVEC;
comment ================== 31062 ================= ;
real procedure INFNRMROW(L, U, I, K, A); value L, U, I;
integer L, U, I, K; array A;
begin real R, MAX;
MAX := 0; K := L;
for L := L step 1 until U do
begin R := ABS(A[I, L]); if R > MAX then
begin MAX := R; K := L end
end;
INFNRMROW := MAX
end INFNRMROW;
comment ================== 31063 ================= ;
real procedure INFNRMCOL(L, U, J, K, A); value L, U, J;
integer L, U, J, K; array A;
begin real R, MAX;
MAX := 0; K := L;
for L := L step 1 until U do
begin R := ABS(A[L, J]); if R > MAX then
begin MAX := R; K := L end
end;
INFNRMCOL := MAX
end INFNRMCOL;
comment ================== 31064 ================= ;
real procedure INFNRMMAT(LR, UR, LC, UC, KR, A);
value LR, UR, LC, UC; integer LR, UR, LC, UC, KR; array A;
begin real R, MAX;
real procedure ONENRMROW(L, U, I, A); code 31066;
MAX := 0; KR := LR;
for LR := LR step 1 until UR do
begin R := ONENRMROW(LC, UC, LR, A); if R > MAX then
begin MAX := R; KR := LR end
end;
INFNRMMAT := MAX
end INFNRMMAT;
comment ================== 31065 ================= ;
real procedure ONENRMVEC(L, U, A); value L, U;
integer L, U; array A;
begin real SUM;
SUM := 0; for L := L step 1 until U do
SUM := SUM + ABS(A[L]);
ONENRMVEC := SUM
end ONENRMVEC;
comment ================== 31066 ================= ;
real procedure ONENRMROW(L, U, I, A); value L, U, I;
integer L, U, I; array A;
begin real SUM;
SUM := 0; for L := L step 1 until U do
SUM := SUM + ABS(A[I, L]);
ONENRMROW := SUM
end ONENRMROW;
comment ================== 31067 ================= ;
real procedure ONENRMCOL(L, U, J, A); value L, U, J;
integer L, U, J; array A;
begin real SUM;
SUM := 0; for L := L step 1 until U do
SUM := SUM + ABS(A[L, J]);
ONENRMCOL := SUM
end ONENRMCOL;
comment ================== 31068 ================= ;
real procedure ONENRMMAT(LR, UR, LC, UC, KC, A);
value LR, UR, LC, UC; integer LR, UR, LC, UC, KC; array A;
begin real MAX, R;
real procedure ONENRMCOL(L, U, J, A); code 31067;
MAX := 0; KC := LC;
for LC := LC step 1 until UC do
begin R := ONENRMCOL(LR, UR, LC, A); if R > MAX then
begin MAX := R; KC := LC end
end;
ONENRMMAT := MAX
end ONENRMMAT;
comment ================== 31069 ================= ;
real procedure ABSMAXMAT(LR, UR, LC, UC, I, J, A);
value LR, UR, LC, UC; integer LR, UR, LC, UC, I, J; array A;
begin integer II; real MAX, R;
real procedure INFNRMCOL(L, U, I, K, A); code 31063;
MAX := 0; I := LR; J := LC;
for LC := LC step 1 until UC do
begin R := INFNRMCOL(LR, UR, LC, II, A); if R > MAX then
begin MAX := R; I := II; J := LC end
end;
ABSMAXMAT := MAX
end ABSMAXMAT;
comment ================== 35140 ================= ;
procedure AIRY(Z, AI, AID, BI, BID, EXPON, FIRST);
value Z, FIRST; Boolean FIRST;
real Z, AI, AID, BI, BID, EXPON;
begin real S, T, U, V, SC, TC, UC, VC, X, K1, K2, K3, K4,
C, ZT, SI, CO, EXPZT, SQRTZ, WWL, PL, PL1, PL2, PL3;
own real C1, C2, SQRT3, SQRT1OPI, PIO4;
own real array XX, WW[1:10];
integer N, L;
if FIRST then
begin SQRT3 := 1.73205080756887729;
SQRT1OPI := 0.56418958354775629;
PIO4 := 0.78539816339744831;
C1 := 0.35502 80538 87817;
C2 := 0.25881 94037 92807;
XX[ 1] := 1.40830 81072 18096410+1;
XX[ 2] := 1.02148 85479 19733110+1;
XX[ 3] := 7.44160 18450 450930 ;
XX[ 4] := 5.30709 43061 781927 ;
XX[ 5] := 3.63401 35029 132462 ;
XX[ 6] := 2.33106 52303 052450 ;
XX[ 7] := 1.34479 70824 609268 ;
XX[ 8] := 6.41888 58369 56729610-1;
XX[ 9] := 2.01003 45998 12104610-1;
XX[10] := 8.05943 59172 05283310-3;
WW[ 1] := 3.15425 15762 96478710-14;
WW[ 2] := 6.63942 10819 58492110-11;
WW[ 3] := 1.75838 89061 34566910-8;
WW[ 4] := 1.37123 92370 43581510-6;
WW[ 5] := 4.43509 66639 28435010-5;
WW[ 6] := 7.15550 10917 71825510-4;
WW[ 7] := 6.48895 66103 33538110-3;
WW[ 8] := 3.64404 15875 77328210-2;
WW[ 9] := 1.43997 92418 59099910-1;
WW[10] := 8.12311 41336 26148610-1;
end;
EXPON := 0;
if Z ≥ -5.0 ∧ Z ≤ 8 then
begin U := V := T := UC := VC := TC := 1;
S := SC := 0.5; N := 0; X := Z × Z × Z;
for N := N + 3 while ABS(U) + ABS(V) + ABS(S) + ABS(T)
> 10-18 do
begin U := U × X/(N × (N-1)); V := V × X/(N × (N + 1));
S := S × X/(N × (N + 2)); T := T × X/(N × (N-2));
UC := UC + U; VC := VC + V; SC := SC + S; TC := TC + T
end;
BI := SQRT3 × (C1 × UC + C2 × Z × VC);
BID := SQRT3 × (C1 × Z × Z × SC + C2 × TC);
if Z < 2.5 then
begin AI := C1 × UC - C2 × Z × VC;
AID := C1 × SC × Z × Z - C2 × TC;
goto END
end
end;
K1 := K2 := K3 := K4 := 0;
SQRTZ := SQRT(ABS(Z));
ZT := 0.66666 66666 66667 × ABS(Z) × SQRTZ;
C := SQRT1OPI/SQRT(SQRTZ);
if Z < 0 then
begin Z := -Z; CO := COS(ZT-PIO4); SI := SIN(ZT-PIO4);
for L := 1 step 1 until 10 do
begin WWL := WW[L]; PL := XX[L]/ZT;
PL2 := PL × PL; PL1 := 1 + PL2; PL3 := PL1 × PL1;
K1 := K1 + WWL/PL1;
K2 := K2 + WWL × PL/PL1;
K3 := K3 + WWL × PL × (1 + PL × (2/ZT + PL))/PL3;
K4 := K4 + WWL × (-1-PL × (1 + PL × (ZT-PL))/ZT)/PL3;
end;
AI := C × (CO × K1 + SI × K2);
AID := 0.25 × AI/Z - C × SQRTZ × (CO × K3 + SI × K4);
BI := C × (CO × K2-SI × K1);
BID := 0.25 × BI/Z - C × SQRTZ × (CO × K4-SI × K3);
end else
begin if Z < 9 then EXPZT := EXP(ZT) else
begin EXPZT := 1; EXPON := ZT end;
for L := 1 step 1 until 10 do
begin WWL := WW[L]; PL := XX[L]/ZT;
PL1 := 1 + PL; PL2 := 1-PL;
K1 := K1 + WWL/PL1;
K2 := K2 + WWL × PL/(ZT × PL1 × PL1);
K3 := K3 + WWL/PL2;
K4 := K4 + WWL × PL/(ZT × PL2 × PL2);
end;
AI := 0.5 × C × K1/EXPZT;
AID := AI × (-.25/Z-SQRTZ) + 0.5 × C × SQRTZ × K2/EXPZT;
if Z ≥ 8 then
begin BI := C × K3 × EXPZT;
BID := BI × (SQRTZ-0.25/Z) - C × K4 × SQRTZ × EXPZT;
end;
end;
END:
end AIRY;
comment ================== 35145 ================= ;
real procedure AIRYZEROS(N, D, ZAI, VAI);
value N, D; integer N, D; array ZAI, VAI;
begin Boolean A, FOUND; integer I;
real C, E, R, ZAJ, ZAK, VAJ, DAJ, KAJ, ZZ;
procedure AIRY(A, B, C, D, E, F, G); code 35140;
A := D = 0 ∨ D = 2;
R := if D = 0 ∨ D = 3 then -1.1780 97245 09617
else -3.5342 91735 28852;
comment R := if D = 0 ∨ D = 3 then -3 × PI / 8
else -9 × PI / 8;
AIRY(0, ZAJ, VAJ, DAJ, KAJ, ZZ, true);
for I := 1 step 1 until N do
begin R := R + 4.7123 88980 38469; comment R := R + 3 × PI / 2;
ZZ := R × R;
ZAJ := if I = 1 ∧ D = 1 then -1.01879 297 else
if I = 1 ∧ D = 2 then -1.17371 322 else
R ⭡ 0.66666 66666 66667 × ( if A then
- ( 1 + ( 5/48 - ( 5/36 - ( 77125/82944 - (
1080 56875 / 69 67296 - (16 23755 96875 / 3344 30208)
/ZZ)/ZZ)/ZZ)/ZZ)/ZZ)
else
- ( 1 - ( 7/48 - ( 35/288 - ( 1 81223 / 2 07360 - (
186 83371 / 12 44160 - ( 9 11458 84361 / 1911 02976 )
/ZZ)/ZZ)/ZZ)/ZZ)/ZZ));
if D ≤ 1 then AIRY(ZAJ, VAJ, DAJ, C, E, ZZ, false)
else AIRY(ZAJ, C, E, VAJ, DAJ, ZZ, false);
FOUND := ABS( if A then VAJ else DAJ ) < 10-12;
for C := C while ¬FOUND do
begin if A then
begin KAJ := VAJ / DAJ;
ZAK := ZAJ - KAJ × (1 + ZAJ × KAJ × KAJ)
end else
begin KAJ := DAJ / (ZAJ × VAJ);
ZAK := ZAJ - KAJ × (1 + KAJ × (KAJ × ZAJ + 1 / ZAJ))
end;
if D ≤ 1 then AIRY(ZAK, VAJ, DAJ, C, E, ZZ, false)
else AIRY(ZAK, C, E, VAJ, DAJ, ZZ, false);
FOUND := ABS(ZAK - ZAJ) < 10-14 × ABS(ZAK) ∨
ABS(if A then VAJ else DAJ) < 10-12;
ZAJ := ZAK
end;
VAI[I] := if A then DAJ else VAJ;
ZAI[I] := ZAJ;
end;
AIRYZEROS := ZAI[N];
end AIRYZEROS;
comment ================== 31040 ================= ;
real procedure POL(N, X, A);
value N, X; integer N; real X; array A;
begin real R;
R := 0;
for N := N step -1 until 0 do
R := R × X + A[N];
POL := R
end POL;
comment ================== 31241 ================= ;
procedure TAYPOL(N, K, X, A);
value N, K, X;
integer N, K; real X; array A;
if X ≠ 0 then
begin integer I, J, NM1;
real XJ, AA, H;
XJ := 1;
for J := 1 step 1 until N do
begin XJ := XJ × X; A[J] := A[J] × XJ end;
AA := A[N]; NM1 := N-1;
for J := 0 step 1 until K do
begin H := AA;
for I := NM1 step -1 until J do
H := A[ I] := A[I] + H
end
end else
for K := K step -1 until 1 do A[K] := 0;
comment ================== 31242 ================= ;
procedure NORDERPOL (N, K, X, A);
value N, K, X;
integer N, K; real X; array A;
if X ≠ 0 then
begin integer I, J, NM1;
real XJ, AA, H;
array XX[0:N];
XJ := 1;
for J := 1 step 1 until N do
begin XJ := XX[J] := XJ × X; A[J] := A[J] × XJ end;
H := AA := A[N]; NM1 := N-1;
for I := NM1 step -1 until 0 do H := A[I] := A[I] + H;
for J := 1 step 1 until K do
begin H := AA;
for I := NM1 step -1 until J do
H := A[ I] := A[I] + H;
A[J] := H/XX[J]
end
end NORDERPOL ;
comment ================== 31243 ================= ;
procedure DERPOL (N, K, X, A);
value N, K, X;
integer N, K; real X; array A;
begin integer J; real FAC;
procedure NORDERPOL(N, K, X, A); code 31242;
FAC := 1;
NORDERPOL (N, K, X, A);
for J := 2 step 1 until K do
begin FAC := FAC × J; A[J] := A[J] × FAC end
end DERPOL ;
comment ================== 32075 ================= ;
real procedure TRICUB(XI, YI, XJ, YJ, XK, YK, G, RE, AE);
value XI, YI, XJ, YJ, XK, YK, RE, AE;
real XI, YI, XJ, YJ, XK, YK, RE, AE; real procedure G;
begin real SURF, SURFMIN, XZ, YZ, GI, GJ, GK;
real procedure INT(AX1, AY1, AF1, AX2, AY2, AF2, AX3, AY3, AF3,
BX1, BY1, BF1, BX2, BY2, BF2, BX3, BY3, BF3,
PX, PY, PF);
value BX1, BY1, BF1, BX2, BY2, BF2, BX3, BY3, BF3, PX, PY, PF;
real BX1, BY1, BF1, BX2, BY2, BF2, BX3, BY3, BF3, PX, PY, PF,
AX1, AY1, AF1, AX2, AY2, AF2, AX3, AY3, AF3;
begin real E, I3, I4, I5, A, B, C, SX1, SY1, SX2, SY2, SX3, SY3,
CX1, CY1, CF1, CX2, CY2, CF2, CX3, CY3, CF3,
DX1, DY1, DF1, DX2, DY2, DF2, DX3, DY3, DF3;
A := AF1 + AF2 + AF3; B := BF1 + BF2 + BF3;
I3 := 3 × A + 27 × PF + 8 × B;
E := ABS(I3) × RE + AE;
if SURF < SURFMIN ∨ ABS(5 × A + 45 × PF - I3) < E
then INT := I3 × SURF else
begin CX1 := AX1 + PX; CY1 := AY1 + PY; CF1 := G(CX1, CY1);
CX2 := AX2 + PX; CY2 := AY2 + PY; CF2 := G(CX2, CY2);
CX3 := AX3 + PX; CY3 := AY3 + PY; CF3 := G(CX3, CY3);
C := CF1 + CF2 + CF3;
I4 := A + 9 × PF + 4 × B + 12 × C;
if ABS(I3 - I4) < E then INT := I4 × SURF else
begin SX1 := .5 × BX1; SY1 := .5 × BY1;
DX1 := AX1 + SX1; DY1 := AY1 + SY1; DF1 := G(DX1, DY1);
SX2 := .5 × BX2; SY2 := .5 × BY2;
DX2 := AX2 + SX2; DY2 := AY2 + SY2; DF2 := G(DX2, DY2);
SX3 := .5 × BX3; SY3 := .5 × BY3;
DX3 := AX3 + SX3; DY3 := AY3 + SY3; DF3 := G(DX3, DY3);
I5 := (51 × A + 2187 × PF + 276 × B + 972 × C -
768 × (DF1 + DF2 + DF3))/63;
if ABS(I4 - I5) < E then INT := I5 × SURF else
begin SURF := .25 × SURF;
INT :=
INT(SX1, SY1, BF1, SX2, SY2, BF2, SX3, SY3, BF3,
DX1, DY1, DF1, DX2, DY2, DF2, DX3, DY3, DF3,
PX, PY, PF) +
INT(AX1, AY1, AF1, SX3, SY3, BF3, SX2, SY2, BF2, DX1, DY1, DF1,
AX1 + SX2, AY1 + SY2, G(AX1 + SX2, AY1 + SY2),
AX1 + SX3, AY1 + SY3, G(AX1 + SX3, AY1 + SY3),
.5 × CX1, .5 × CY1, CF1) +
INT(AX2, AY2, AF2, SX3, SY3, BF3, SX1, SY1, BF1, DX2, DY2, DF2,
AX2 + SX1, AY2 + SY1, G(AX2 + SX1, AY2 + SY1),
AX2 + SX3, AY2 + SY3, G(AX2 + SX3, AY2 + SY3),
.5 × CX2, .5 × CY2, CF2) +
INT(AX3, AY3, AF3, SX1, SY1, BF1, SX2, SY2, BF2, DX3, DY3, DF3,
AX3 + SX2, AY3 + SY2, G(AX3 + SX2, AY3 + SY2),
AX3 + SX1, AY3 + SY1, G(AX3 + SX1, AY3 + SY1),
.5 × CX3, .5 × CY3, CF3);
SURF := 4 × SURF
end
end
end
end INT;
SURF := 0.5 × ABS(XJ × YK - XK × YJ + XI × YJ -
XJ × YI + XK × YI - XI × YK);
SURFMIN := SURF × RE; RE := 30 × RE; AE := 30 × AE/SURF;
XZ := (XI + XJ + XK)/3; YZ := (YI + YJ + YK)/3;
GI := G(XI, YI); GJ := G(XJ, YJ); GK := G(XK, YK);
XI := XI × .5; YI := YI × .5; XJ := XJ × .5;
YJ := YJ × .5; XK := XK × .5; YK := YK × .5;
TRICUB := INT(XI, YI, GI, XJ, YJ, GJ, XK, YK, GK,
XJ + XK, YJ + YK, G(XJ + XK, YJ + YK),
XK + XI, YK + YI, G(XK + XI, YK + YI),
XI + XJ, YI + YJ, G(XI + XJ, YI + YJ),
.5 × XZ, .5 × YZ, G(XZ, YZ))/60
end TRICUB;
comment ================== 34444 ================= ;
procedure PEIDE(N, M, NOBS, NBP, PAR, RES, BP, JTJINV, IN, OUT, DERIV, JAC DFDY,
JAC DFDP, CALL YSTART, DATA, MONITOR);
value N, M, NOBS; integer N, M, NOBS, NBP;
array PAR, RES, JTJINV, IN, OUT;
integer array BP;
procedure CALL YSTART, DATA, MONITOR;
Boolean procedure DERIV, JAC DFDY, JACDFDP;
begin integer I, J, EXTRA, WEIGHT, NCOL, NROW, AWAY, NPAR, II, JJ, MAX,
NFE, NIS;
real EPS, EPS1, XEND, C, X, T, HMIN, HMAX, RES1, IN3, IN4, FAC3, FAC4;
array AUX[1:3], OBS[1:NOBS], SAVE[-38:6 × N], TOBS[0:NOBS],
YP[1:NBP + NOBS, 1:NBP + M], YMAX[1:N], Y[1:6 × N × (NBP + M + 1)], FY[1:N, 1:N],
FP[1:N, 1:M + NBP];
integer array COBS[1:NOBS];
Boolean FIRST, SEC, CLEAN;
procedure INIVEC(L, U, A, X); code 31010;
procedure INIMAT(L1, U1, L2, U2, A, X); code 31011;
procedure MULVEC(L, U, S, A, B, X); code 31020;
procedure MULROW(L, U, I, J, A, B, X); code 31021;
procedure DUPVEC(L, U, S, A, B); code 31030;
procedure DUPMAT(L1, U1, L2, U2, A, B); code 31035;
real procedure VECVEC(L, U, S, A, B); code 34010;
real procedure MATVEC(L, U, I, A, B); code 34011;
procedure ELMVEC(L, U, S, A, B, X); code 34020;
procedure SOL(A, N, P, B); code 34051;
procedure DEC(A, N, AUX, P); code 34300;
procedure MARQUARDT(M, N, P, R, C, F, J, I, O); code 34440;
real procedure INTERPOL(STARTINDEX, JUMP, K, TOBSDIF);
value STARTINDEX, JUMP, K, TOBSDIF;
integer STARTINDEX, JUMP, K; real TOBSDIF;
begin integer I; real S, R; S := Y[STARTINDEX]; R := TOBSDIF;
for I := 1 step 1 until K do
begin STARTINDEX := STARTINDEX + JUMP;
S := S + Y[STARTINDEX] × R; R := R × TOBSDIF
end; INTERPOL := S
end INTERPOL;
procedure JAC DYDP(NROW, NCOL, PAR, RES, JAC, LOCFUNCT);
value NROW, NCOL; integer NROW, NCOL;
array PAR, RES, JAC; procedure LOCFUNCT;
begin
DUPMAT(1, NROW, 1, NCOL, JAC, YP)
end JACOBIAN;
Boolean procedure FUNCT(NROW, NCOL, PAR, RES);
value NROW, NCOL; integer NROW, NCOL; array PAR, RES;
begin integer L, K, KNEW, FAILS, SAME, KPOLD, N6, NNPAR, J5N,
COBSII;
real XOLD, HOLD, A0, TOLUP, TOL, TOLDWN, TOLCONV, H, CH, CHNEW,
ERROR, DFI, TOBSDIF;
Boolean EVALUATE, EVALUATED, DECOMPOSE, CONV;
array A[0:5], DELTA, LAST DELTA, DF, Y0[1:N], JACOB[1:N, 1:N];
integer array P[1:N];
real procedure NORM2(AI); real AI;
begin real S, A; S := 10-100;
for I := 1 step 1 until N do
begin A := AI/YMAX[I]; S := S + A × A end;
NORM2 := S
end NORM2;
procedure RESET;
begin if CH < HMIN/HOLD then CH := HMIN/HOLD else
if CH > HMAX/HOLD then CH := HMAX/HOLD;
X := XOLD; H := HOLD × CH; C := 1;
for J := 0 step N until K × N do
begin for I := 1 step 1 until N do
Y[J + I] := SAVE[J + I] × C;
C := C × CH
end;
DECOMPOSE := true
end RESET;
procedure ORDER;
begin C := EPS × EPS; J := (K-1) × (K + 8)/2 - 38;
for I := 0 step 1 until K do A[I] := SAVE[I + J];
J := J + K + 1;
TOLUP := C × SAVE[J];
TOL := C × SAVE[J + 1];
TOLDWN := C × SAVE[J + 2];
TOLCONV := EPS/(2 × N × (K + 2));
A0 := A[0]; DECOMPOSE := true;
end ORDER;
procedure EVALUATE JACOBIAN;
begin EVALUATE := false;
DECOMPOSE := EVALUATED := true;
if ¬JAC DFDY(PAR, Y, X, FY) then
begin SAVE[-3] := 4; goto RETURN end;
end EVALUATE JACOBIAN;
procedure DECOMPOSE JACOBIAN;
begin DECOMPOSE := false;
C := -A0 × H;
for J := 1 step 1 until N do
begin for I := 1 step 1 until N do
JACOB[I, J] := FY[I, J] × C;
JACOB[J, J] := JACOB[J, J] + 1
end;
DEC(JACOB, N, AUX, P)
end DECOMPOSE JACOBIAN;
procedure CALCULATE STEP AND ORDER;
begin real A1, A2, A3;
A1 := if K ≤ 1 then 0 else
0.75 × (TOLDWN/NORM2(Y[K × N + I])) ⭡ (0.5/K);
A2 := 0.80 × (TOL/ERROR) ⭡ (0.5/(K + 1));
A3 := if K ≥ 5 ∨ FAILS ≠ 0
then 0 else
0.70 × (TOLUP/NORM2(DELTA[I] - LAST DELTA[I]))⭡
(0.5/(K + 2));
if A1 > A2 ∧ A1 > A3 then
begin KNEW := K-1; CHNEW := A1 end else
if A2 > A3 then
begin KNEW := K ; CHNEW := A2 end else
begin KNEW := K + 1; CHNEW := A3 end
end CALCULATE STEP AND ORDER;
if SEC then begin SEC := false; goto RETURN end;
NPAR := M; EXTRA := NIS := 0; II := 1;
JJ := if NBP = 0 then 0 else 1;
N6 := N × 6;
INIVEC(-3, -1, SAVE, 0);
INIVEC(N6 + 1, (6 + M) × N, Y, 0);
INIMAT(1, NOBS + NBP, 1, M + NBP, YP, 0);
T := TOBS[1]; X := TOBS[0];
CALL YSTART(PAR, Y, YMAX);
HMAX := TOBS[1]-TOBS[0]; HMIN := HMAX × IN[1];
EVALUATE JACOBIAN; NNPAR := N × NPAR;
NEW START:
K := 1; KPOLD := 0; SAME := 2; ORDER;
if ¬DERIV(PAR, Y, X, DF) then
begin SAVE[-3] := 3; goto RETURN end;
H := SQRT(2 × EPS/SQRT(NORM2 (MATVEC(1, N, I, FY, DF))));
if H > HMAX then H := HMAX else
if H < HMIN then H := HMIN;
XOLD := X; HOLD := H; CH := 1;
for I := 1 step 1 until N do
begin SAVE[I] := Y[I]; SAVE[N + I] := Y[N + I] := DF[I] × H end;
FAILS := 0;
for L := 0 while X < XEND do
begin if X + H ≤ XEND then X := X + H else
begin H := XEND-X; X := XEND; CH := H/HOLD; C := 1;
for J := N step N until K × N do
begin C := C × CH;
for I := J + 1 step 1 until J + N do
Y[I] := Y[I] × C
end;
SAME := if SAME < 3 then 3 else SAME + 1;
end;
comment PREDICTION;
for L := 1 step 1 until N do
begin for I := L step N until (K-1) × N + L do
for J := (K-1) × N + L step -N until I do
Y[J] := Y[J] + Y[J + N];
DELTA[L] := 0
end; EVALUATED := false;
comment CORRECTION AND ESTIMATION LOCAL ERROR;
for L := 1, 2, 3 do
begin if ¬DERIV(PAR, Y, X, DF) then
begin SAVE[-3] := 3; goto RETURN end;
for I := 1 step 1 until N do
DF[I] := DF[I] × H - Y[N + I];
if EVALUATE then EVALUATE JACOBIAN;
if DECOMPOSE then DECOMPOSE JACOBIAN;
SOL(JACOB, N, P, DF);
CONV := true;
for I := 1 step 1 until N do
begin DFI := DF[I];
Y[ I] := Y[ I] + A0 × DFI;
Y[N + I] := Y[N + I] + DFI;
DELTA[I] := DELTA[I] + DFI;
CONV := CONV ∧ ABS(DFI) < TOLCONV × YMAX[I]
end;
if CONV then
begin ERROR := NORM2(DELTA[I]);
goto CONVERGENCE
end
end;
comment ACCEPTANCE OR REJECTION;
if ¬CONV then
begin if ¬EVALUATED then EVALUATE := true
else
begin CH := CH/4; if H < 4 × HMIN then
begin SAVE[-1] := SAVE[-1] + 10;
HMIN := HMIN/10;
if SAVE[-1] > 40 then goto RETURN
end
end;
RESET
end else CONVERGENCE:
if ERROR > TOL then
begin FAILS := FAILS + 1;
if H > 1.1 × HMIN then
begin if FAILS > 2 then
begin RESET; goto NEW START
end else
begin CALCULATE STEP AND ORDER;
if KNEW ≠ K then
begin K := KNEW; ORDER end;
CH := CH × CHNEW; RESET
end
end else
begin if K = 1 then
begin comment VIOLATE EPS CRITERION;
SAVE[-2] := SAVE[-2] + 1;
SAME := 4; goto ERROR TEST OK
end;
K := 1; RESET; ORDER; SAME := 2
end
end else ERROR TEST OK:
begin FAILS := 0;
for I := 1 step 1 until N do
begin C := DELTA[I];
for L := 2 step 1 until K do
Y[L × N + I] := Y[L × N + I] + A[L] × C;
if ABS(Y[I]) > YMAX[I] then
YMAX[I] := ABS(Y[I])
end;
SAME := SAME-1;
if SAME = 1 then
DUPVEC(1, N, 0, LAST DELTA, DELTA) else
if SAME = 0 then
begin CALCULATE STEP AND ORDER;
if CHNEW > 1.1 then
begin
if K ≠ KNEW then
begin if KNEW > K then
MULVEC(KNEW × N + 1, KNEW × N + N, -KNEW × N, Y, DELTA,
A[K]/KNEW);
K := KNEW; ORDER
end;
SAME := K + 1;
if CHNEW × H > HMAX
then CHNEW := HMAX/H;
H := H × CHNEW; C := 1;
for J := N step N until K × N do
begin C := C × CHNEW;
MULVEC(J + 1, J + N, 0, Y, Y, C)
end; DECOMPOSE := true
end
else SAME := 10
end OF A SINGLE INTEGRATION STEP OF Y;
NIS := NIS + 1;
comment START OF A INTEGRATION STEP OF YP;
if CLEAN then
begin HOLD := H; XOLD := X; KPOLD := K; CH := 1;
DUPVEC(1, K × N + N, 0, SAVE, Y)
end else
begin if H ≠ HOLD then
begin CH := H/HOLD; C := 1;
for J := N6 + NNPAR step NNPAR until
KPOLD × NNPAR + N6 do
begin C := C × CH;
for I := J + 1 step 1 until J + NNPAR do
Y[I] := Y[I] × C
end; HOLD := H
end;
if K > KPOLD then
INIVEC(N6 + K × NNPAR + 1, N6 + K × NNPAR + NNPAR, Y, 0);
XOLD := X; KPOLD := K; CH := 1;
DUPVEC(1, K × N + N, 0, SAVE, Y);
EVALUATE JACOBIAN;
DECOMPOSE JACOBIAN;
if ¬JAC DFDP(PAR, Y, X, FP) then
begin SAVE[-3] := 5; goto RETURN end;
if NPAR > M then INIMAT(1, N, M + 1, NPAR, FP, 0);
comment PREDICTION;
for L := 0 step 1 until K-1 do
for J := K-1 step -1 until L do
ELMVEC(J × NNPAR + N6 + 1, J × NNPAR + N6 + NNPAR, NNPAR, Y, Y, 1);
comment CORRECTION;
for J := 1 step 1 until NPAR do
begin J5N := (J + 5) × N;
DUPVEC(1, N, J5N, Y0, Y);
for I := 1 step 1 until N do DF[I] :=
H × (FP[I, J] + MATVEC(1, N, I, FY, Y0))
-Y[NNPAR + J5N + I];
SOL(JACOB, N, P, DF);
for L := 0 step 1 until K do
begin I := L × NNPAR + J5N;
ELMVEC(I + 1, I + N, -I, Y, DF, A[L])
end
end
end;
for L := 0 while X ≥ T do
begin
comment CALCULATION OF A ROW OF THE JACOBIAN
MATRIX AND AN ELEMENT OF THE RESIDUAL
VECTOR;
TOBSDIF := (TOBS[II]-X)/H; COBSII := COBS[II];
RES[II] := INTERPOL(COBSII, N, K, TOBSDIF)-OBS[II];
if ¬CLEAN then
begin for I := 1 step 1 until NPAR do
YP[II, I] := INTERPOL(COBSII + (I + 5) × N, NNPAR, K,
TOBSDIF);
comment INTRODUCING OF BREAK-POINTS;
if BP[JJ] ≠ II then else
if FIRST ∧ ABS(RES[II]) < EPS1 then
begin NBP := NBP-1; DUPVEC(JJ, NBP, 1, BP, BP);
BP[NBP + 1] := 0
end else
begin EXTRA := EXTRA + 1;
if FIRST then PAR[M + JJ] := OBS[II];
comment INTRODUCING A JACOBIAN ROW AND A
RESIDUAL VECTOR ELEMENT FOR
CONTINUITY REQUIREMENTS;
YP[NOBS + JJ, M + JJ] := -WEIGHT;
MULROW(1, NPAR, NOBS + JJ, II, YP, YP, WEIGHT);
RES[NOBS + JJ] := WEIGHT × (RES[II] + OBS[II]-
PAR[M + JJ])
end
end;
if II = NOBS then goto RETURN else
begin T := TOBS[II + 1];
if BP[JJ] = II ∧ JJ < NBP then JJ := JJ + 1;
HMAX := T-TOBS[II]; HMIN := HMAX × IN[1]; II := II + 1
end;
end;
comment BREAK-POINTS INTRODUCE NEW INITIAL VALUES
FOR Y AND YP;
if EXTRA > 0 then
begin for I := 1 step 1 until N do
begin Y[I] := INTERPOL(I, N, K, TOBSDIF);
for J := 1 step 1 until NPAR do
Y[I + (J + 5) × N] := INTERPOL(I + (J + 5) × N, NNPAR, K,
TOBSDIF)
end;
for L := 1 step 1 until EXTRA do
begin COBSII := COBS[BP[NPAR-M + L]];
Y[COBSII] := PAR[NPAR + L];
for I := 1 step 1 until NPAR + EXTRA do
Y[COBSII + (5 + I) × N] := 0;
INIVEC(1 + NNPAR + (L + 5) × N, NNPAR + (L + 6) × N, Y, 0);
Y[COBSII + (5 + NPAR + L) × N] := 1
end;
NPAR := NPAR + EXTRA; EXTRA := 0;
X := TOBS[II-1]; EVALUATE JACOBIAN; NNPAR := N × NPAR;
goto NEW START
end
end
end STEP;
RETURN:
if SAVE[-2] > MAX then MAX := SAVE[-2];
FUNCT := SAVE[-1] ≤ 40 ∧ SAVE[-3] = 0;
if ¬FIRST then
MONITOR(1, NCOL, NROW, PAR, RES, WEIGHT, NIS)
end FUNCT;
I := -39;
for C := 1, 1, 9, 4, 0, 2/3, 1, 1/3, 36, 20.25, 1, 6/11,
1, 6/11, 1/11, 84.028, 53.778, 0.25, .48, 1, .7, .2, .02,
156.25, 108.51, .027778, 120/274, 1, 225/274,
85/274, 15/274, 1/274, 0, 187.69, .0047361
do begin I := I + 1; SAVE[I] := C end;
DATA(NOBS, TOBS, OBS, COBS); WEIGHT := 1;
FIRST := SEC := false; CLEAN := NBP > 0;
AUX[2] := 10-12; EPS := IN[2]; EPS1 := 1010;
XEND := TOBS[NOBS]; OUT[1] := 0; BP[0] := MAX := 0;
comment SMOOTH INTEGRATION WITHOUT BREAK-POINTS;
if ¬FUNCT(NOBS, M, PAR, RES) then goto ESCAPE;
RES1 := SQRT(VECVEC(1, NOBS, 0, RES, RES)); NFE := 1;
if IN[5] = 1 then
begin OUT[1] := 1; goto ESCAPE end;
if CLEAN then
begin FIRST := true; CLEAN := false;
FAC3 := SQRT(SQRT(IN[3]/RES1)); FAC4 := SQRT(SQRT(IN[4]/RES1));
EPS1 := RES1 × FAC4;
if ¬FUNCT(NOBS, M, PAR, RES) then goto ESCAPE;
FIRST := false
end else NFE := 0;
NCOL := M + NBP; NROW := NOBS + NBP;
SEC := true;
IN3 := IN[3]; IN4 := IN[4]; IN[3] := RES1;
begin real W; array AID[1:NCOL, 1:NCOL];
WEIGHT := AWAY := 0;
OUT[4] := OUT[5] := W := 0;
for WEIGHT := (SQRT(WEIGHT) + 1)⭡2 while
WEIGHT ≠ 16 ∧ NBP > 0 do
begin if AWAY = 0 ∧ W ≠ 0 then
begin comment IF NO BREAK-POINTS WERE OMITTED THEN ONE
FUNCTION EVALUATION IS SAVED;
W := WEIGHT/W;
for I := NOBS + 1 step 1 until NROW do
begin for J := 1 step 1 until NCOL do
YP[I, J] := W × YP[I, J];
RES[I] := W × RES[I]
end; SEC := true; NFE := NFE-1
end;
IN[3] := IN[3] × FAC3 × WEIGHT; IN[4] := EPS1;
MONITOR(2, NCOL, NROW, PAR, RES, WEIGHT, NIS);
MARQUARDT(NROW, NCOL, PAR, RES, AID, FUNCT, JAC DYDP, IN, OUT);
if OUT[1] > 0 then goto ESCAPE;
comment THE RELATIVE STARTING VALUE OF LAMBDA IS
ADJUSTED TO THE LAST VALUE OF LAMBDA USED;
AWAY := OUT[4]-OUT[5]-1;
IN[6] := IN[6] × 5⭡AWAY × 2⭡(AWAY-OUT[5]);
NFE := NFE + OUT[4];
W := WEIGHT; EPS1 := (SQRT(WEIGHT) + 1)⭡2 × IN[4] × FAC4;
AWAY := 0;
comment USELESS BREAK-POINTS ARE OMITTED;
for J := 1 step 1 until NBP do
begin if ABS(OBS[BP[J]] + RES[BP[J]]-PAR[J + M]) < EPS1
then
begin NBP := NBP-1; DUPVEC(J, NBP, 1, BP, BP);
DUPVEC(J + M, NBP + M, 1, PAR, PAR);
J := J-1; AWAY := AWAY + 1; BP[NBP + 1] := 0
end
end;
NCOL := NCOL-AWAY; NROW := NROW-AWAY
end;
IN[3] := IN3; IN[4] := IN4; NBP := 0; WEIGHT := 1;
MONITOR(2, M, NOBS, PAR, RES, WEIGHT, NIS);
MARQUARDT(NOBS, M, PAR, RES, JTJINV, FUNCT, JAC DYDP, IN, OUT);
NFE := OUT[4] + NFE
end;
ESCAPE: if OUT[1] = 3 then OUT[1] := 2 else
if OUT[1] = 4 then OUT[1] := 6;
if SAVE[-3] ≠ 0 then OUT[1] := SAVE[-3];
OUT[3] := RES1;
OUT[4] := NFE;
OUT[5] := MAX
end PEIDE;
comment ================== 33300 ================= ;
procedure FEM LAG SYM(X, Y, N, P, R, F, ORDER, E);
integer N, ORDER;
real procedure P, R, F;
array X, Y, E;
begin integer L, L1;
real XL1, XL, H, A12, B1, B2, TAU1, TAU2, CH, TL, G, YL, PP,
P1, P2, P3, P4, R1, R2, R3, R4, F1, F2, F3, F4,
E1, E2, E3, E4, E5, E6;
array T, SUB, CHI, GI[0:N-1];
procedure ELEMENT MAT VEC EVALUATION 1;
begin real H2;
if L = 1 then
begin P2 := P(XL1); R2 := R(XL1); F2 := F(XL1) end;
P1 := P2; P2 := P(XL); R1 := R2; R2 := R(XL); F1 := F2; F2 := F(XL);
H2 := H/2; B1 := H2 × F1; B2 := H2 × F2; TAU1 := H2 × R1; TAU2 := H2 × R2;
A12 := -0.5 × (P1 + P2)/H
end ELAN. M.V. EV.;
procedure ELEMENT MAT VEC EVALUATION 2;
begin real X2, H6, H15, B3, TAU3, C12, C32, A13, A22, A23;
if L = 1 then
begin P3 := P(XL1); R3 := R(XL1); F3 := F(XL1) end;
X2 := (XL1 + XL)/2; H6 := H/6; H15 := H/1.5;
P1 := P3; P2 := P(X2); P3 := P(XL);
R1 := R3; R2 := R(X2); R3 := R(XL);
F1 := F3; F2 := F(X2); F3 := F(XL);
B1 := H6 × F1; B2 := H15 × F2; B3 := H6 × F3;
TAU1 := H6 × R1; TAU2 := H15 × R2; TAU3 := H6 × R3;
A12 := -(2 × P1 + P3/1.5)/H; A13 := (0.5 × (P1 + P3) - P2/1.5)/H;
A22 := (P1 + P3)/H/0.375 + TAU2; A23 := -(P1/3 + P3) × 2/H;
comment STATIC CONDENSATION;
C12 := - A12/A22; C32 := - A23/A22; A12 := A13 + C32 × A12;
B1 := B1 + C12 × B2; B2 := B3 + C32 × B2;
TAU1 := TAU1 + C12 × TAU2; TAU2 := TAU3 + C32 × TAU2
end ELEMENT MAT VEC EVALUATION 2;
procedure ELEMENT MAT VEC EVALUATION 3;
begin real X2, X3, H12, H24, DET, C12, C13, C42, C43,
A13, A14, A22, A23, A24, A33, A34, B3, B4, TAU3, TAU4;
if L = 1 then
begin P4 := P(XL1); R4 := R(XL1); F4 := F(XL1) end;
X2 := XL1 + 0.27639320225 × H; X3 := XL - X2 + XL1;
H12 := H/12; H24 := H/2.4;
P1 := P4; P2 := P(X2); P3 := P(X3); P4 := P(XL);
R1 := R4; R2 := R(X2); R3 := R(X3); R4 := R(XL);
F1 := F4; F2 := F(X2); F3 := F(X3); F4 := F(XL);
B1 := H12 × F1; B2 := H24 × F2; B3 := H24 × F3; B4 := H12 × F4;
TAU1 := H12 × R1; TAU2 := H24 × R2; TAU3 := H24 × R3; TAU4 := H12 × R4;
A12 := -( + 4.04508497187450 × P1
+ 0.57581917135425 × P3
+ 0.25751416197911 × P4)/H;
A13 := ( + 1.5450849718747 × P1
- 1.5075141619791 × P2
+ 0.6741808286458 × P4)/H;
A14 := ((P2 + P3)/2.4 - (P1 + P4)/2)/H;
A22 := (5.454237476562 × P1 + P3/.48 + .79576252343762 × P4)/H + TAU2;
A23 := - (P1 + P4)/(H × 0.48);
A24 := ( + 0.67418082864575 × P1
- 1.50751416197910 × P3
+ 1.54508497187470 × P4)/H;
A33 := (.7957625234376 × P1 + P2/.48 + 5.454237476562 × P4)/H + TAU3;
A34 := -( + 0.25751416197911 × P1
+ 0.57581917135418 × P2
+ 4.0450849718747 × P4)/H;
comment STATIC CONDENSATION;
DET := A22 × A33 - A23 × A23;
C12 := (A13 × A23 - A12 × A33)/DET;
C13 := (A12 × A23 - A13 × A22)/DET;
C42 := (A23 × A34 - A24 × A33)/DET;
C43 := (A24 × A23 - A34 × A22)/DET;
TAU1 := TAU1 + C12 × TAU2 + C13 × TAU3;
TAU2 := TAU4 + C42 × TAU2 + C43 × TAU3;
A12 := A14 + C42 × A12 + C43 × A13;
B1 := B1 + C12 × B2 + C13 × B3;
B2 := B4 + C42 × B2 + C43 × B3
end ELEMENT MAT VEC EVALUATION 3;
procedure BOUNDARY CONDITIONS;
if L = 1 ∧ E2 = 0 then
begin TAU1 := 1; B1 := E3/E1; B2 := B2 - A12 × B1;
TAU2 := TAU2 - A12; A12 := 0 end
else if L = 1 ∧ E2 ≠ 0 then
begin real AUX; AUX := P1/E2; TAU1 := TAU1 - AUX × E1 ;
B1 := B1 - E3 × AUX
end else if L = N ∧ E5 = 0 then
begin TAU2 := 1; B2 := E6/E4;
B1 := B1 - A12 × B2; TAU1 := TAU1 - A12; A12 := 0
end else if L = N ∧ E5 ≠ 0 then
begin real AUX; AUX := P2/E5;
TAU2 := TAU2 + AUX × E4; B2 := B2 + AUX × E6
end B.C.1;
procedure FORWARD BABUSHKA;
if L = 1 then
begin CHI[0] := CH := TL := TAU1; T[0] := TL;
GI[0] := G := YL := B1; Y[0] := YL;
SUB[0] := A12; PP := A12/(CH - A12);
CH := TAU2 - CH × PP; G := B2 - G × PP; TL := TAU2; YL := B2
end else
begin CHI[L1] := CH := CH + TAU1;
GI[L1] := G := G + B1;
SUB[L1] := A12; PP := A12/(CH - A12);
CH := TAU2 - CH × PP; G := B2 - G × PP;
T[L1] := TL + TAU1; TL := TAU2;
Y[L1] := YL + B1; YL := B2
end FORWARD BABUSHKA 1;
procedure BACKWARD BABUSHKA;
begin PP := YL; Y[N] := G/CH;
G := PP; CH := TL; L := N;
for L := L - 1 while L ≥ 0 do
begin PP := SUB[L]; PP := PP/(CH - PP);
TL := T[L]; CH := TL - CH × PP;
YL := Y[L]; G := YL - G × PP;
Y[L] := (GI[L] + G - YL)/(CHI[L] + CH - TL)
end
end BACKWARD BABUSHKA;
L := 0; XL := X[0];
E1 := E[1]; E2 := E[2]; E3 := E[3]; E4 := E[4]; E5 := E[5]; E6 := E[6];
for L := L + 1 while L ≤ N do
begin L1 := L - 1; XL1 := XL; XL := X[L]; H := XL - XL1;
if ORDER = 2 then ELEMENT MAT VEC EVALUATION 1 else
if ORDER = 4 then ELEMENT MAT VEC EVALUATION 2 else
ELEMENT MAT VEC EVALUATION 3;
if L = 1 ∨ L = N then BOUNDARY CONDITIONS;
FORWARD BABUSHKA
end;
BACKWARD BABUSHKA;
end FEM LAG SYM;
comment ================== 33301 ================= ;
procedure FEM LAG(X, Y, N, R, F, ORDER, E);
value N, ORDER; integer N, ORDER;
real procedure R, F;
array X, Y, E;
begin integer L, L1;
real XL1, XL, H, A12, B1, B2, TAU1, TAU2, CH, TL, G, YL, PP,
E1, E2, E3, E4, E5, E6;
array T, SUB, CHI, GI[0: N-1];
procedure ELEMENT MAT VEC EVALUATION 1;
begin own real F2, R2; real R1, F1, H2;
if L = 1 then
begin F2 := F(XL1); R2 := R(XL1) end;
A12 := - 1/H; H2 := H/2;
R1 := R2; R2 := R(XL); F1 := F2; F2 := F(XL);
B1 := H2 × F1; B2 := H2 × F2; TAU1 := H2 × R1; TAU2 := H2 × R2
end ELEMENT MAT VEC EVALUATION 1;
procedure ELEMENT MAT VEC EVALUATION 2;
begin own real R3, F3;
real R1, R2, F1, F2, X2, H6, H15,
B3, TAU3, C12, A13, A22, A23;
if L = 1 then
begin R3 := R(XL1); F3 := F(XL1) end;
X2 := (XL1 + XL)/2; H6 := H/6; H15 := H/1.5;
R1 := R3; R2 := R(X2); R3 := R(XL);
F1 := F3; F2 := F(X2); F3 := F(XL);
B1 := H6 × F1; B2 := H15 × F2; B3 := H6 × F3;
TAU1 := H6 × R1; TAU2 := H15 × R2; TAU3 := R3 × H6;
A12 := A23 := -8/H/3; A13 := - A12/8; A22 := -2 × A12 + TAU2;
comment STATIC CONDENSATION;
C12 := - A12/A22; A12 := A13 + C12 × A12;
B2 := C12 × B2; B1 := B1 + B2; B2 := B3 + B2;
TAU2 := C12 × TAU2; TAU1 := TAU1 + TAU2; TAU2 := TAU3 + TAU2
end ELEMENT MAT VEC EVALUATION2;
procedure ELEMENT MAT VEC EVALUATION 3;
begin own real R4, F4;
real R1, R2, R3, F1, F2, F3, X2, X3, H12, H24,
DET, C12, C13, C42, C43, A13, A14, A22, A23, A24,
A33, A34, B3, B4, TAU3, TAU4;
if L = 1 then
begin R4 := R(XL1); F4 := F(XL1) end;
X2 := XL1 + 0.27639320225 × H; X3 := XL - X2 + XL1;
R1 := R4; R2 := R(X2); R3 := R(X3); R4 := R(XL);
F1 := F4; F2 := F(X2); F3 := F(X3); F4 := F(XL);
H12 := H/12; H24 := H/2.4;
B1 := F1 × H12; B2 := F2 × H24; B3 := F3 × H24; B4 := F4 × H12;
TAU1 := R1 × H12; TAU2 := R2 × H24; TAU3 := R3 × H24; TAU4 := R4 × H12;
A12 := A34 := -4.8784183052078/H; A13 := A24 := 0.7117516385412/H;
A14 := -0.16666666666667/H; A23 := 25 × A14;
A22 := -2 × A23 + TAU2; A33 := -2 × A23 + TAU3;
comment STATIC CONDENSATION;
DET := A22 × A33 - A23 × A23;
C12 := (A13 × A23 - A12 × A33)/DET;
C13 := (A12 × A23 - A13 × A22)/DET;
C42 := (A23 × A34 - A24 × A33)/DET;
C43 := (A24 × A23 - A34 × A22)/DET;
TAU1 := TAU1 + C12 × TAU2 + C13 × TAU3;
TAU2 := TAU4 + C42 × TAU2 + C43 × TAU3;
A12 := A14 + C42 × A12 + C43 × A13;
B1 := B1 + C12 × B2 + C13 × B3;
B2 := B4 + C42 × B2 + C43 × B3
end ELEMENT MAT VEC EVALUATION3;
procedure BOUNDARY CONDITIONS;
if L = 1 ∧ E2 = 0 then
begin TAU1 := 1; B1 := E3/E1; B2 := B2 - A12 × B1;
TAU2 := TAU2 - A12; A12 := 0 end
else if L = 1 ∧ E2 ≠ 0 then
begin TAU1 := TAU1 - E1/E2;
B1 := B1 - E3/E2
end else if L = N ∧ E5 = 0 then
begin TAU2 := 1; B2 := E6/E4; B1 := B1 - A12 × B2;
TAU1 := TAU1 - A12; A12 := 0
end else if L = N ∧ E5 ≠ 0 then
begin TAU2 := TAU2 + E4/E5;
B2 := B2 + E6/E5
end BOUNDARY CONDITIONS;
procedure FORWARD BABUSHKA;
if L = 1 then
begin CHI[0] := CH := TL := TAU1; T[0] := TL;
GI[0] := G := YL := B1; Y[0] := YL;
SUB[0] := A12; PP := A12/(CH - A12); CH := TAU2 - CH × PP;
G := B2 - G × PP; TL := TAU2; YL := B2
end else
begin CHI[L1] := CH := CH + TAU1;
GI[L1] := G := G + B1; SUB[L1] := A12; PP := A12/(CH - A12);
CH := TAU2 - CH × PP; G := B2 - G × PP;
T[L1] := TL + TAU1; TL := TAU2;
Y[L1] := YL + B1; YL := B2
end FORWARD BABUSHKA 1;
procedure BACKWARD BABUSHKA;
begin PP := YL; Y[N] := G/CH;
G := PP; CH := TL; L := N;
for L := L - 1 while L ≥ 0 do
begin PP := SUB[L]; PP := PP/(CH - PP);
TL := T[L]; CH := TL - CH × PP;
YL := Y[L]; G := YL - G × PP;
Y[L] := ((GI[L] + G) - YL)/((CHI[L] + CH) - TL)
end
end BACKWARD BABUSHKA;
L := 0; XL := X[0];
E1 := E[1]; E2 := E[2]; E3 := E[3]; E4 := E[4]; E5 := E[5]; E6 := E[6];
for L := L + 1 while L ≤ N do
begin L1 := L - 1; XL1 := XL; XL := X[L]; H := XL - XL1;
if ORDER = 2 then ELEMENT MAT VEC EVALUATION 1 else
if ORDER = 4 then ELEMENT MAT VEC EVALUATION 2 else
ELEMENT MAT VEC EVALUATION 3;
if L = 1 ∨ L = N then BOUNDARY CONDITIONS;
FORWARD BABUSHKA
end;
BACKWARD BABUSHKA;
end FEM LAGR;
comment ================== 33302 ================= ;
procedure FEM LAG SKEW(X, Y, N, Q, R, F, ORDER, E);
integer N, ORDER;
real procedure Q, R, F;
array X, Y, E;
begin integer L, L1;
real XL1, XL, H, A12, A21, B1, B2, TAU1, TAU2, CH, TL, G, YL, PP,
E1, E2, E3, E4, E5, E6;
array T, SUPER, SUB, CHI, GI[0:N-1];
procedure ELEMENT MAT VEC EVALUATION 1;
begin own real Q2, R2, F2;
real Q1, R1, F1, H2, S12;
if L = 1 then
begin Q2 := Q(XL1); R2 := R(XL1); F2 := F(XL1) end;
H2 := H/2; S12 := - 1/H;
Q1 := Q2; Q2 := Q(XL);
R1 := R2; R2 := R(XL);
F1 := F2; F2 := F(XL);
B1 := H2 × F1; B2 := H2 × F2;
TAU1 := H2 × R1; TAU2 := H2 × R2;
A12 := S12 + Q1/2; A21 := S12 - Q2/2
end ELEMENT MAT VEC EV.;
procedure ELEMENT MAT VEC EVALUATION 2;
begin own real Q3, R3, F3;
real Q1, Q2, R1, R2, F1, F2, S12, S13, S22, X2, H6, H15,
C12, C32, A13, A31, A22, A23, A32, B3, TAU3;
if L = 1 then
begin Q3 := Q(XL1); R3 := R(XL1); F3 := F(XL1) end;
X2 := (XL1 + XL)/2; H6 := H/6; H15 := H/1.5;
Q1 := Q3; Q2 := Q(X2); Q3 := Q(XL);
R1 := R3; R2 := R(X2); R3 := R(XL);
F1 := F3; F2 := F(X2); F3 := F(XL);
B1 := H6 × F1; B2 := H15 × F2; B3 := H6 × F3;
TAU1 := H6 × R1; TAU2 := H15 × R2; TAU3 := H6 × R3;
S12 := - 1/H/0.375; S13 := - S12/8; S22 := - 2 × S12;
A12 := S12 + Q1/1.5; A13 := S13 - Q1/6;
A21 := S12 - Q2/1.5; A23 := S12 + Q2/1.5; A22 := S22 + TAU2;
A31 := S13 + Q3/6; A32 := S12 - Q3/1.5;
comment STATIC CONDENSATION;
C12 := - A12/A22; C32 := - A32/A22;
A12 := A13 + C12 × A23; A21 := A31 + C32 × A21;
B1 := B1 + C12 × B2; B2 := B3 + C32 × B2;
TAU1 := TAU1 + C12 × TAU2; TAU2 := TAU3 + C32 × TAU2
end ELEMENT MAT VEC EVALUATION 2;
procedure ELEMENT MAT VEC EVALUATION 3;
begin own real Q4, R4, F4;
real Q1, Q2, Q3, R1, R2, R3, F1, F2, F3,
S12, S13, S14, S22, S23, X2, X3, H12, H24,
DET, C12, C13, C42, C43, A13, A14, A22, A23,
A24, A31, A32, A33, A34, A41, A42, A43,
B3, B4, TAU3, TAU4;
if L = 1 then
begin Q4 := Q(XL1); R4 := R(XL1); F4 := F(XL1) end;
X2 := XL1 + 0.27639320225 × H; X3 := XL - X2 + XL1;
H12 := H/12; H24 := H/2.4;
Q1 := Q4; Q2 := Q(X2); Q3 := Q(X3); Q4 := Q(XL);
R1 := R4; R2 := R(X2); R3 := R(X3); R4 := R(XL);
F1 := F4; F2 := F(X2); F3 := F(X3); F4 := F(XL);
S12 := -4.8784183052080/H; S13 := 0.7117516385414/H;
S14 := -.16666666666667/H; S23 := 25 × S14; S22 := -2 × S23;
B1 := H12 × F1; B2 := H24 × F2; B3 := H24 × F3; B4 := H12 × F4;
TAU1 := H12 × R1; TAU2 := H24 × R2; TAU3 := H24 × R3; TAU4 := H12 × R4;
A12 := S12 + 0.67418082864578 × Q1;
A13 := S13 - 0.25751416197912 × Q1;
A14 := S14 + Q1/12;
A21 := S12 - 0.67418082864578 × Q2;
A22 := S22 + TAU2;
A23 := S23 + 0.93169499062490 × Q2;
A24 := S13 - 0.25751416197912 × Q2;
A31 := S13 + 0.25751416197912 × Q3;
A32 := S23 - 0.93169499062490 × Q3;
A33 := S22 + TAU3;
A34 := S12 + 0.67418082864578 × Q3;
A41 := S14 - Q4/12;
A42 := S13 + 0.25751416197912 × Q4;
A43 := S12 - 0.67418082864578 × Q4;
comment STATIC CONDENSATION;
DET := A22 × A33 - A23 × A32;
C12 := (A13 × A32 - A12 × A33)/DET;
C13 := (A12 × A23 - A13 × A22)/DET;
C42 := (A32 × A43 - A42 × A33)/DET;
C43 := (A42 × A23 - A43 × A22)/DET;
TAU1 := TAU1 + C12 × TAU2 + C13 × TAU3 ;
TAU2 := TAU4 + C42 × TAU2 + C43 × TAU3;
A12 := A14 + C12 × A24 + C13 × A34;
A21 := A41 + C42 × A21 + C43 × A31;
B1 := B1 + C12 × B2 + C13 × B3;
B2 := B4 + C42 × B2 + C43 × B3
end ELEMENT MAT VEC EVALUATION 3;
procedure BOUNDARY CONDITIONS;
if L = 1 ∧ E2 = 0 then
begin TAU1 := 1; B1 := E3/E1; A12 := 0 end
else if L = 1 ∧ E2 ≠ 0 then
begin TAU1 := TAU1 - E1/E2; B1 := B1 - E3/E2
end else if L = N ∧ E5 = 0 then
begin TAU2 := 1; A21 := 0; B2 := E6/E4;
end else if L = N ∧ E5 ≠ 0 then
begin TAU2 := TAU2 + E4/E5; B2 := B2 + E6/E5
end B.C.1;
procedure FORWARD BABUSKA;
if L = 1 then
begin CHI[0] := CH := TL := TAU1; T[0] := TL;
GI[0] := G := YL := B1; Y[0] := YL;
SUB[0] := A21; SUPER[0] := A12;
PP := A21/(CH - A12); CH := TAU2 - CH × PP;
G := B2 - G × PP; TL := TAU2; YL := B2
end else
begin CHI[L1] := CH := CH + TAU1;
GI[L1] := G := G + B1;
SUB[L1] := A21; SUPER[L1] := A12;
PP := A21/(CH - A12); CH := TAU2 - CH × PP;
G := B2 - G × PP; T[L1] := TL + TAU1; TL := TAU2;
Y[L1] := YL + B1; YL := B2
end FORWARD BABUSKA;
procedure BACKWARD BABUSKA;
begin PP := YL; Y[N] := G/CH;
G := PP; CH := TL; L := N;
for L := L - 1 while L ≥ 0 do
begin PP := SUPER[L]/(CH - SUB[L]);
TL := T[L]; CH := TL - CH × PP;
YL := Y[L]; G := YL - G × PP;
Y[L] := (GI[L] + G - YL)/(CHI[L] + CH - TL) ;
end
end BACKWARD BABUSKA;
L := 0; XL := X[0];
E1 := E[1]; E2 := E[2]; E3 := E[3]; E4 := E[4]; E5 := E[5]; E6 := E[6];
comment ELEMENTWISE ASSEMBLAGE OF MATRIX AND VECTOR
COMBINED WITH FORWARD BABUSKA SUBSTITUTION;
for L := L + 1 while L ≤ N do
begin XL1 := XL; L1 := L - 1; XL := X[L]; H := XL - XL1;
if ORDER = 2 then ELEMENT MAT VEC EVALUATION 1 else
if ORDER = 4 then ELEMENT MAT VEC EVALUATION 2 else
ELEMENT MAT VEC EVALUATION 3;
if L = 1 ∨ L = N then BOUNDARY CONDITIONS;
FORWARD BABUSKA
end;
BACKWARD BABUSKA;
end FEM LAGR;
comment ================== 33303 ================= ;
procedure FEM HERM SYM(X, Y, N, P, Q, R, F, ORDER, E);
value N, ORDER; integer N, ORDER;
array X, Y, E;
real procedure P, Q, R, F;
begin integer L, N2, V, W;
array A[1:8 × (N - 1)], EM[2:3];
real A11, A12, A13, A14, A22, A23, A24, A33, A34, A44,
YA, YB, ZA, ZB,
B1, B2, B3, B4, D1, D2, E1, R1, R2, XL1, XL;
procedure CHLDECSOLBND(A, N, W, AUX, B); code 34333;
procedure ELEMENTMATVECEVALUATION;
if ORDER = 4 then
begin real X2, H, H2, H3, P1, P2,
Q1, Q2, R1, R2, F1, F2,
B11, B12, B13, B14, B22, B23, B24, B33, B34, B44,
S11, S12, S13, S14, S22, S23, S24, S33, S34, S44,
M11, M12, M13, M14, M22, M23, M24, M33, M34, M44;
own real P3, Q3, R3, F3;
H := XL - XL1; H2 := H × H; H3 := H × H2;
X2 := (XL1 + XL)/2;
if L = 1 then
begin P3 := P(XL1); Q3 := Q(XL1); R3 := R(XL1); F3 := F(XL1)
end;
comment ELEMENT BENDING MATRIX;
P1 := P3; P2 := P(X2); P3 := P(XL);
B11 := 6 × (P1 + P3); B12 := 4 × P1 + 2 × P3;
B13 := - B11; B14 := B11 - B12;
B22 := (4 × P1 + P2 + P3)/1.5; B23 := - B12; B24 := B12 - B22;
B33 := B11; B34 := - B14; B44 := B14 - B24;
comment ELEMENT STIFFNESS MATRIX;
Q1 := Q3; Q2 := Q(X2); Q3 := Q(XL);
S11 := 1.5 × Q2; S12 := Q2/4; S13 := - S11; S14 := S12;
S24 := Q2/24; S22 := Q1/6 + S24; S23 := - S12;
S33 := S11; S34 := - S12; S44 := S24 + Q3/6;
comment ELEMENT MASS MATRIX;
R1 := R3; R2 := R(X2); R3 := R(XL);
M11 := (R1 + R2)/6; M12 := R2/24; M13 := R2/6; M14 := - M12;
M22 := R2/96; M23 := - M14; M24 := - M22;
M33 := (R2 + R3)/6; M34 := M14; M44 := M22;
comment ELEMENT LOAD VECTOR;
F1 := F3; F2 := F(X2); F3 := F(XL);
B1 := H × (F1 + 2 × F2)/6; B3 := H × (F3 + 2 × F2)/6;
B2 := H2 × F2/12; B4 := - B2;
A11 := B11/H3 + S11/H + M11 × H; A12 := B12/H2 + S12 + M12 × H2;
A13 := B13/H3 + S13/H + M13 × H; A14 := B14/H2 + S14 + M14 × H2;
A22 := B22/H + S22 × H + M22 × H3; A23 := B23/H2 + S23 + M23 × H2;
A24 := B24/H + S24 × H + M24 × H3; A34 := B34/H2 + S34 + M34 × H2;
A33 := B33/H3 + S33/H + M33 × H; A44 := B44/H + S44 × H + M44 × H3
end else if ORDER = 6 then
begin own real P4, Q4, R4, F4;
real H, H2, H3, X2, X3,
P1, P2, P3, Q1, Q2, Q3,
R1, R2, R3, F1, F2, F3,
B11, B12, B13, B14, B15, B22, B23, B24, B25,
B33, B34, B35, B44, B45, B55,
S11, S12, S13, S14, S15, S22, S23, S24, S25,
S33, S34, S35, S44, S45, S55,
M11, M12, M13, M14, M15, M22, M23, M24, M25,
M33, M34, M35, M44, M45, M55,
A15, A25, A35, A45, A55, C1, C2, C3, C4, B5;
if L = 1 then
begin P4 := P(XL1); Q4 := Q(XL1); R4 := R(XL1); F4 := F(XL1)
end;
H := XL - XL1; H2 := H × H; H3 := H × H2;
X2 := 0.27639320225 × H + XL1; X3 := XL1 + XL - X2;
comment ELEMENT BENDING MATRIX;
P1 := P4; P2 := P(X2); P3 := P(X3); P4 := P(XL);
B11 := + 4.033333333333310+1 × P1 + 1.112491386673810-1 × P2
+ 1.442208419466410+1 × P3 + 8.333333333333310+0 × P4;
B12 := + 1.466666666666710+1 × P1 - 3.319142509165910-1 × P2
+ 2.798580917581810+0 × P3 + 1.666666666666710+0 × P4;
B13 := + 1.833333333333310+1 × (P1 + P4)
+ 1.266666666666710+0 × (P2 + P3);
B15 := - (B11 + B13); B14 := - (B12 + B13 + B15/2);
B22 := + 5.333333333333310+0 × P1 + 9.902734644167410-1 × P2
+ 5.430598689162410-1 × P3 + 3.333333333333310-1 × P4;
B23 := + 6.666666666666710+0 × P1 - 3.779127846416710+0 × P2
+ 2.457945130829510-1 × P3 + 3.666666666666710+0 × P4;
B25 := - (B12 + B23); B24 := - (B22 + B23 + B25/2);
B33 := + 8.333333333333310+0 × P1 + 1.442208419466610+1 × P2
+ 1.112491386672610-1 × P3 + 4.033333333333310+1 × P4;
B35 := - (B13 + B33); B34 := - (B23 + B33 + B35/2);
B45 := - (B14 + B34); B44 := - (B24 + B34 + B45/2);
B55 := - (B15 + B35);
comment ELEMENT STIFFNESS MATRIX;
Q1 := Q4; Q2 := Q(X2); Q3 := Q(X3); Q4 := Q(XL);
S11 := + 2.884416838933010+0 × Q2 + 2.224982773344810-2 × Q3;
S12 := + 2.567105187249810-1 × Q2 + 3.289481274999410-3 × Q3;
S13 := + 2.533333333333310-1 × (Q2 + Q3);
S14 := - 3.745355992500510-2 × Q2 - 2.254644007498810-2 × Q3;
S15 := - (S13 + S11);
S22 := + 8.333333333333310-2 × Q1 + 2.284700655416410-2 × Q2
+ 4.863267791644510-4 × Q3;
S23 := + 2.254644007500210-2 × Q2 + 3.745355992487310-2 × Q3;
S24 := - 3.333333333333310-3 × (Q2 + Q3);
S25 := - (S12 + S23);
S33 := + 2.224982773347110-2 × Q2 + 2.884416838933010+0 × Q3;
S34 := - 3.289481275012710-3 × Q2 - 2.567105187249610-1 × Q3;
S35 := - (S13 + S33);
S44 := + 4.863267791678810-4 × Q2
+ 2.284700655416110-2 × Q3 + 8.333333333333810-2 × Q4;
S45 := - (S14 + S34);
S55 := - (S15 + S35);
comment ELEMENT MASS MATRIX;
R1 := R4; R2 := R(X2); R3 := R(X3); R4 := R(XL);
M11 := + 8.333333333333310-2 × R1 + 1.012907608608310-1 × R2
+ 7.375905805838010-3 × R3;
M12 := + 1.329618127333310-2 × R2 + 1.370485393335310-3 × R3;
M13 := - 2.733333333333310-2 × (R2 + R3);
M14 := + 5.078689325833510-3 × R2 + 3.587977340833310-3 × R3;
M15 := + 1.314798711599910-1 × R2 - 3.547987115999110-2 × R3;
M22 := + 1.745355992500010-3 × R2 + 2.546440075005910-4 × R3;
M23 := - 3.587977340833610-3 × R2 - 5.078689325838510-3 × R3;
M24 := + 6.666666666666710-4 × (R2 + R3);
M25 := + 1.725902921333310-2 × R2 - 6.592362546671910-3 × R3;
M33 := + 7.375905805838010-3 × R2
+ 1.012907608608310-1 × R3 + 8.333333333333310-2 × R4;
M34 := - 1.370485393333310-3 × R2 - 1.329618127333310-2 × R3;
M35 := - 3.547987115999210-2 × R2 + 1.314798711599910-1 × R3;
M44 := + 2.546440075000810-4 × R2 + 1.745355992499710-3 × R3;
M45 := + 6.592362546665610-3 × R2 - 1.725902921333010-2 × R3;
M55 := + .1706666666666710+0 × (R2 + R3);
comment ELEMENT LOAD VECTOR;
F1 := F4; F2 := F(X2); F3 := F(X3); F4 := F(XL);
B1 := + 8.333333333333310-2 × F1 + 2.054372986874910-1 × F2
- 5.543729868748910-2 × F3;
B2 := + 2.696723314583210-2 × F2 - 1.030056647917510-2 × F3;
B3 := - 5.543729868748910-2 × F2
+ 2.054372986874910-1 × F3 + 8.333333333333310-2 × F4;
B4 := + 1.030056647916510-2 × F2 - 2.696723314583010-2 × F3;
B5 := + 2.666666666666710-1 × (F2 + F3);
A11 := H2 × (H2 × M11 + S11) + B11; A12 := H2 × (H2 × M12 + S12) + B12;
A13 := H2 × (H2 × M13 + S13) + B13; A14 := H2 × (H2 × M14 + S14) + B14;
A15 := H2 × (H2 × M15 + S15) + B15; A22 := H2 × (H2 × M22 + S22) + B22;
A23 := H2 × (H2 × M23 + S23) + B23; A24 := H2 × (H2 × M24 + S24) + B24;
A25 := H2 × (H2 × M25 + S25) + B25; A33 := H2 × (H2 × M33 + S33) + B33;
A34 := H2 × (H2 × M34 + S34) + B34; A35 := H2 × (H2 × M35 + S35) + B35;
A44 := H2 × (H2 × M44 + S44) + B44; A45 := H2 × (H2 × M45 + S45) + B45;
A55 := H2 × (H2 × M55 + S55) + B55;
comment STATIC CONDENSATION;
C1 := A15/A55; C2 := A25/A55; C3 := A35/A55; C4 := A45/A55;
B1 := (B1 - C1 × B5) × H; B2 := (B2 - C2 × B5) × H2;
B3 := (B3 - C3 × B5) × H; B4 := (B4 - C4 × B5) × H2;
A11 := (A11 - C1 × A15)/H3; A12 := (A12 - C1 × A25)/H2;
A13 := (A13 - C1 × A35)/H3; A14 := (A14 - C1 × A45)/H2;
A22 := (A22 - C2 × A25)/H; A23 := (A23 - C2 × A35)/H2;
A24 := (A24 - C2 × A45)/H; A33 := (A33 - C3 × A35)/H3;
A34 := (A34 - C3 × A45)/H2; A44 := (A44 - C4 × A45)/H;
end else
begin own real P5, Q5, R5, F5;
real X2, X3, X4, H, H2, H3,
P1, P2, P3, P4, Q1, Q2, Q3, Q4,
R1, R2, R3, R4, F1, F2, F3, F4,
B11, B12, B13, B14, B15, B16, B22, B23, B24, B25, B26,
B33, B34, B35, B36, B44, B45, B46, B55, B56, B66,
S11, S12, S13, S14, S15, S16, S22, S23, S24, S25, S26,
S33, S34, S35, S36, S44, S45, S46, S55, S56, S66,
M11, M12, M13, M14, M15, M16, M22, M23, M24, M25, M26,
M33, M34, M35, M36, M44, M45, M46, M55, M56, M66,
C15, C16, C25, C26, C35, C36, C45, C46, B5, B6,
A15, A16, A25, A26, A35, A36, A45, A46, A55, A56, A66, DET;
if L = 1 then
begin P5 := P(XL1); Q5 := Q(XL1); R5 := R(XL1); F5 := F(XL1)
end;
H := XL - XL1; H2 := H × H; H3 := H × H2;
X2 := XL1 + H × .172673164646; X3 := XL1 + H/2; X4 := XL1 + XL - X2;
comment ELEMENT BENDING MATRIX;
P1 := P5; P2 := P(X2); P3 := P(X3); P4 := P(X4); P5 := P(XL);
B11 := + 105.8 × P1 + 9.8 × P5 + 7.359312130351310-2 × P2
+ 2.275555555555610+1 × P3 + 7.056565608855310+0 × P4;
B12 := + 27.6 × P1 + 1.4 × P5 - 3.4155482481110-1 × P2
+ 2.844444444444410+0 × P3 + 1.011396094652210+0 × P4;
B13 := - 32.2 × (P1 + P5) - 7.206349206350510-1 × (P2 + P4)
+ 2.275555555555610+1 × P3;
B14 := + 4.6 × P1 + 8.4 × P5 + 1.032864122294410-1 × P2
- 2.844444444444410+0 × P3 - 3.344556253499210+0 × P4;
B15 := - (B11 + B13); B16 := - (B12 + B13 + B14 + B15/2);
B22 := + 7.2 × P1 + 0.2 × P5 + 1.585198402858110+0 × P2
+ 3.555555555555610-1 × P3 + 1.449603273005910-1 × P4;
B23 := - 8.4 × P1 - 4.6 × P5 + 3.344556253499210+0 × P2
+ 2.844444444444410+0 × P3 - 1.032864122294410-1 × P4;
B24 := + 1.2 × (P1 + P5) - 4.793650793650810-1 × (P2 + P4)
- 3.555555555555610-1 × P3;
B25 := - (B12 + B23); B26 := - (B22 + B23 + B24 + B25/2);
B33 := + 7.056565608855310+0 × P2 + 2.275555555555610+1 × P3
+ 7.359312130351310-2 × P4 + 105.8 × P5 + 9.8 × P1;
B34 := - 1.4 × P1 - 27.6 × P5 - 1.011396094652210+0 × P2
- 2.844444444444410+0 × P3 + 3.415548248110010-1 × P4;
B35 := - (B13 + B33); B36 := - (B23 + B33 + B34 + B35/2);
B44 := + 7.2 × P5 + P1/5 + 1.449603273005910-1 × P2
+ 3.555555555555610-1 × P3 + 1.585198402858110+0 × P4;
B45 := - (B14 + B34); B46 := - (B24 + B34 + B44 + B45/2);
B55 := - (B15 + B35); B56 := - (B16 + B36);
B66 := - (B26 + B36 + B46 + B56/2);
comment ELEMENT STIFFNESS MATRIX;
Q1 := Q5; Q2 := Q(X2); Q3 := Q(X3); Q4 := Q(X4); Q5 := Q(XL);
S11 := + 3.024242403795110+0 × Q2 + 3.153990913006510-2 × Q4;
S12 := + 1.257552558174410-1 × Q2 + 4.176716971674210-3 × Q4;
S13 := - 3.088435374149610-1 × (Q2 + Q4);
S14 := + 4.089904124306210-2 × Q2 + 1.284245535557710-2 × Q4;
S15 := - (S13 + S11);
S16 := + 5.925486117706810-1 × Q2 + 6.051261271911610-2 × Q4;
S22 := + 5.229205286542210-3 × Q2 + 5.531076386279610-4 × Q4 + Q1/20;
S23 := - 1.284245535557710-2 × Q2 - 4.089904124306210-2 × Q4;
S24 := + 1.700680272108810-3 × (Q2 + Q4);
S25 := - (S12 + S23);
S26 := + 2.463959309742610-2 × Q2 + 8.013468127064110-3 × Q4;
S33 := + 3.153990913006510-2 × Q2 + 3.024242403795110+0 × Q4;
S34 := - 4.176716971674210-3 × Q2 - 1.257552558174410-1 × Q4;
S35 := - (S13 + S33);
S36 := - 6.051261271911610-2 × Q2 - 5.925486117706810-1 × Q4;
S44 := + 5.531076386279610-4 × Q2 + 5.229205286542210-3 × Q4 + Q5/20;
S45 := - (S14 + S34);
S46 := + 8.013468127064110-3 × Q2 + 2.463959309742610-2 × Q4;
S55 := - (S15 + S35); S56 := -(S16 + S36);
S66 := + 1.160997732426310-1 × (Q2 + Q4) + 3.555555555555610-1 × Q3;
comment ELEMENT MASS MATRIX;
R1 := R5; R2 := R(X2); R3 := R(X3); R4 := R(X4); R5 := R(XL);
M11 := + 9.710702072731010-2 × R2 + 1.581025919918010-3 × R4 + R1/20;
M12 := + 8.235488946025410-3 × R2 + 2.193215496007110-4 × R4;
M13 := + 1.239067055393610-2 × (R2 + R4);
M14 := - 1.718846624996810-3 × R2 - 1.050832675293910-3 × R4;
M15 := + 5.308978971211910-2 × R2 + 6.774155866106010-3 × R4;
M16 := - 1.737771285607610-2 × R2 + 2.217363001846610-3 × R4;
M22 := + 6.984384617314510-4 × R2 + 3.042451202934910-5 × R4;
M23 := + 1.050832675294710-3 × R2 + 1.718846624993610-3 × R4;
M24 := - 1.457725947520610-4 × (R2 + R4);
M25 := + 4.502458967912710-3 × R2 + 9.397179028337410-4 × R4;
M26 := - 1.473775645278010-3 × R2 + 3.075948872599810-4 × R4;
M33 := + 1.581025919920910-3 × R2 + 9.710702072729010-2 × R4 + R5/20;
M34 := - 2.193215496013110-4 × R2 - 8.235488946025410-3 × R4;
M35 := + 6.774155866112310-3 × R2 + 5.308978971211210-2 × R4;
M36 := - 2.217363001849210-3 × R2 + 1.737771285607110-2 × R4;
M44 := + 3.042451202945710-5 × R2 + 6.984384617315810-4 × R4;
M45 := - 9.397179028354210-4 × R2 - 4.502458967913110-3 × R4;
M46 := + 3.075948872606010-4 × R2 - 1.473775645277810-3 × R4;
M55 := + 2.902494331065710-2 × (R2 + R4) + 3.555555555555610-1 × R3;
M56 := + 9.500642840205010-3 × (R4-R2);
M66 := + 3.109815354712510-3 × (R2 + R4);
comment ELEMENT LOAD VECTOR;
F1 := F5; F2 := F(X2); F3 := F(X3); F4 := F(X4); F5 := F(XL);
B1 := + 1.625874809933610-1 × F2 + 2.074585233996910-2 × F4 + F1/20;
B2 := + 1.378878058923310-2 × F2 + 2.877886077433510-3 × F4;
B3 := + 2.074585233996910-2 × F2 + 1.625874809933610-1 × F4 + F5/20;
B4 := - 2.877886077433510-3 × F2 - 1.378878058923310-2 × F4;
B5 := + (F2 + F4)/11.25 + 3.555555555555610-1 × F3;
B6 := + 2.909571869813210-2 × (F4-F2);
A11 := H2 × (H2 × M11 + S11) + B11; A12 := H2 × (H2 × M12 + S12) + B12;
A13 := H2 × (H2 × M13 + S13) + B13; A14 := H2 × (H2 × M14 + S14) + B14;
A15 := H2 × (H2 × M15 + S15) + B15; A16 := H2 × (H2 × M16 + S16) + B16;
A22 := H2 × (H2 × M22 + S22) + B22; A23 := H2 × (H2 × M23 + S23) + B23;
A24 := H2 × (H2 × M24 + S24) + B24; A25 := H2 × (H2 × M25 + S25) + B25;
A26 := H2 × (H2 × M26 + S26) + B26; A33 := H2 × (H2 × M33 + S33) + B33;
A34 := H2 × (H2 × M34 + S34) + B34; A35 := H2 × (H2 × M35 + S35) + B35;
A36 := H2 × (H2 × M36 + S36) + B36; A44 := H2 × (H2 × M44 + S44) + B44;
A45 := H2 × (H2 × M45 + S45) + B45; A46 := H2 × (H2 × M46 + S46) + B46;
A55 := H2 × (H2 × M55 + S55) + B55; A56 := H2 × (H2 × M56 + S56) + B56;
A66 := H2 × (H2 × M66 + S66) + B66;
comment STATIC CONDENSATION;
DET := - A55 × A66 + A56 × A56;
C15 := (A15 × A66 - A16 × A56)/DET; C16 := (A16 × A55 - A15 × A56)/DET;
C25 := (A25 × A66 - A26 × A56)/DET; C26 := (A26 × A55 - A25 × A56)/DET;
C35 := (A35 × A66 - A36 × A56)/DET; C36 := (A36 × A55 - A35 × A56)/DET;
C45 := (A45 × A66 - A46 × A56)/DET; C46 := (A46 × A55 - A45 × A56)/DET;
A11 := (A11 + C15 × A15 + C16 × A16)/H3;
A12 := (A12 + C15 × A25 + C16 × A26)/H2;
A13 := (A13 + C15 × A35 + C16 × A36)/H3;
A14 := (A14 + C15 × A45 + C16 × A46)/H2;
A22 := (A22 + C25 × A25 + C26 × A26)/H;
A23 := (A23 + C25 × A35 + C26 × A36)/H2;
A24 := (A24 + C25 × A45 + C26 × A46)/H;
A33 := (A33 + C35 × A35 + C36 × A36)/H3;
A34 := (A34 + C35 × A45 + C36 × A46)/H2;
A44 := (A44 + C45 × A45 + C46 × A46)/H;
B1 := (B1 + C15 × B5 + C16 × B6) × H; B2 := (B2 + C25 × B5 + C26 × B6) × H2;
B3 := (B3 + C35 × B5 + C36 × B6) × H; B4 := (B4 + C45 × B5 + C46 × B6) × H2;
end EL.MATVECEVAL.;
L := 1; W := V := 0; N2 := N + N - 2; XL1 := X[0]; XL := X[1];
YA := E[1]; ZA := E[2]; YB := E[3]; ZB := E[4];
ELEMENTMATVECEVALUATION; EM[2] := 10-12;
R1 := B3 - A13 × YA - A23 × ZA; D1 := A33; D2 := A44;
R2 := B4 - A14 × YA - A24 × ZA; E1 := A34;
for L := L + 1 while L < N do
begin XL1 := XL; XL := X[L];
ELEMENTMATVECEVALUATION;
A[W + 1] := D1 + A11; A[W + 4] := E1 + A12;
A[W + 7] := A13; A[W + 10] := A14;
A[W + 5] := D2 + A22; A[W + 8] := A23;
A[W + 11] := A24; A[W + 14] := 0;
Y[V + 1] := R1 + B1; Y[V + 2] := R2 + B2;
R1 := B3; R2 := B4; V := V + 2; W := W + 8;
D1 := A33; D2 := A44; E1 := A34
end;
L := N; XL1 := XL; XL := X[L]; ELEMENTMATVECEVALUATION;
Y[N2 - 1] := R1 + B1 - A13 × YB - A14 × ZB;
Y[N2] := R2 + B2 - A23 × YB - A24 × ZB;
A[W + 1] := D1 + A11; A[W + 4] := E1 + A12; A[W + 5] := D2 + A22;
CHLDECSOLBND(A, N2, 3, EM, Y)
end FEMHERM;
comment ================== 34600 ================= ;
procedure QZIVAL(N, A, B, ALFR, ALFI, BETA, ITER, EM);
value N; integer N; array A, B, ALFR, ALFI, BETA, EM;
integer array ITER;
begin real DWARF, EPS, EPSA, EPSB;
procedure ELMCOL(L, U, I, J, A, B, X); code 34023;
procedure HSHDECMUL(N, A, B, DWARF); code 34602;
procedure HESTGL2(N, A, B); code 34604;
procedure HSH2ROW2(LA, LB, UA, UB, J, A1, A2, A, B); code 34608;
procedure HSH3ROW2(LA, LB, U, J, A1, A2, A3, A, B); code 34610;
procedure HSH2COL(LA, LB, U, I, A1, A2, A, B); code 34605;
procedure HSH3COL(LA, LB, U, I, A1, A2, A3, A, B); code 34606;
procedure CHSH2(A1R, A1I, A2R, A2I, C, SR, SI); code 34611;
procedure HSHVECMAT(LR, UR, LC, UC, X, U, A); code 31070;
procedure HSHVECTAM(LR, UR, LC, UC, X, U, A); code 31073;
procedure QZIT(N, A, B, EPS, EPSA, EPSB, ITER); value N, EPS;
real EPS, EPSA, EPSB; integer N; integer array ITER; array A, B;
begin real ANORM, BNORM, ANI, BNI, CONST, A10, A20, A30, B11,
B22, B33, B44, A11, A12, A21, A22, A33, A34, A43, A44, B12, B34, OLD1, OLD2;
integer I, Q, M, M1, Q1, J, K, K1, K2, K3, KM1; Boolean STATIONARY;
ANORM := BNORM := 0; for I := 1 step 1 until N do
begin BNI := 0; ITER[I] := 0; ANI := if I > 1 then ABS(A[I, I-1]) else 0;
for J := I step 1 until N do
begin ANI := ANI + ABS(A[I, J]); BNI := BNI + ABS(B[I, J])
end; if ANI > ANORM then ANORM := ANI; if BNI > BNORM then
BNORM := BNI
end; if ANORM = 0 then ANORM := EPS; if BNORM = 0 then BNORM := EPS;
EPSA := EPS × ANORM; EPSB := EPS × BNORM;
for M := N, M while M ≥ 3 do
begin
for I := M + 1, I-1 while (if I > 1 then ABS(A[I, I-1]) > EPSA else
false) do Q := I-1;
if Q > 1 then A[Q, Q-1] := 0;
L: if Q ≥ M-1 then M := Q-1 else
begin
if ABS(B[Q, Q]) ≤ EPSB then
begin B[Q, Q] := 0; Q1 := Q + 1;
HSH2COL(Q, Q, M, Q, A[Q, Q], A[Q1, Q], A, B); A[Q1, Q] := 0;
Q := Q1; goto L
end else M1 := M-1; Q1 := Q + 1; CONST := 0.75; ITER[M] := ITER[M] + 1;
STATIONARY := if ITER[M] = 1 then true else
ABS(A[M, M-1]) ≥ CONST × OLD1 ∧ ABS(A[M-1, M-2]) ≥ CONST × OLD2;
if ITER[M] > 30 ∧ STATIONARY then
begin for I := 1 step 1 until M do ITER[I] := -1;
goto OUT
end;
if ITER[M] = 10 ∧ STATIONARY then
begin A10 := 0; A20 := 1; A30 := 1.1605
end else
begin B11 := B[Q, Q]; B22 := if ABS(B[Q1, Q1]) < EPSB then EPSB
else B[Q1, Q1];
B33 := if ABS(B[M1, M1]) < EPSB then EPSB else B[M1, M1];
B44 := if ABS(B[M, M]) < EPSB then EPSB else B[M, M] ;
A11 := A[Q, Q]/B11; A12 := A[Q, Q1]/B22; A21 := A[Q1, Q]/B11;
A22 := A[Q1, Q1]/B22; A33 := A[M1, M1]/B33; A34 := A[M1, M]/B44;
A43 := A[M, M1]/B33; A44 := A[M, M]/B44; B12 := B[Q, Q1]/B22;
B34 := B[M1, M]/B44;
A10 := ((A33-A11) × (A44-A11)-A34 × A43 + A43 × B34 × A11)/A21
+ A12-A11 × B12;
A20 := (A22-A11-A21 × B12)-(A33-A11)-(A44-A11) + A43 × B34;
A30 := A[Q + 2, Q1]/B22
end; OLD1 := ABS(A[M, M-1]); OLD2 := ABS(A[M-1, M-2]);
for K := Q step 1 until M1 do
begin K1 := K + 1; K2 := K + 2; K3 := if K + 3 > M then M else K + 3;
KM1 := if K-1 < Q then Q else K-1;
if K ≠ M1 then
begin if K = Q then
begin
HSH3COL(KM1, KM1, M, K, A[K, KM1], A[K1, KM1], A[K2, KM1], A, B);
A[K1, KM1] := A[K2, KM1] := 0
end;
HSH3ROW2(Q, Q, K3, K, B[K2, K2], B[K2, K1], B[K2, K], A, B);
B[K2, K] := B[K2, K1] := 0 ;
end else
begin HSH2COL(KM1, KM1, M, K, A[K, KM1], A[K1, KM1], A, B);
A[K1, KM1] := 0
end;
HSH2ROW2(Q, Q, K3, K3, K, B[K1, K1], B[K1, K], A, B); B[K1, K] := 0
end
end;
OUT:
end
end QZIT;
comment ================== 34601 ================= ;
procedure QZI(N, A, B, X, ALFR, ALFI, BETA, ITER, EM);
value N; integer N; array A, B, X, ALFR, ALFI, BETA, EM;
integer array ITER;
begin real DWARF, EPS, EPSA, EPSB;
real procedure MATMAT(L, U, I, J, A, B); code 34013;
procedure HSHDECMUL(N, A, B, DWARF); code 34602;
procedure HESTGL3(N, A, B, X); code 34603;
procedure HSH2ROW3(L, UA, UB, UX, J, A1, A2, A, B, X); code 34607;
procedure HSH3ROW3(L, U, UX, J, A1, A2, A3, A, B, X); code 34609;
procedure HSH2COL(LA, LB, U, I, A1, A2, A, B); code 34605;
procedure HSH3COL(LA, LB, U, I, A1, A2, A3, A, B); code 34606;
procedure CHSH2(A1R, A1I, A2R, A2I, C, SR, SI); code 34611;
procedure COMDIV(XR, XI, YR, YI, ZR, ZI); code 34342;
procedure QZIT(N, A, B, X, EPS, EPSA, EPSB, ITER); value N, EPS;
real EPS, EPSA, EPSB; integer N; integer array ITER; array A, B, X;
begin real ANORM, BNORM, ANI, BNI, CONST, A10, A20, A30, B11,
B22, B33, B44, A11, A12, A21, A22, A33, A34, A43, A44, B12, B34, OLD1, OLD2;
integer I, Q, M, M1, Q1, J, K, K1, K2, K3, KM1; Boolean STATIONARY;
ANORM := BNORM := 0; for I := 1 step 1 until N do
begin BNI := 0; ITER[I] := 0; ANI := if I > 1 then ABS(A[I, I-1]) else 0;
for J := I step 1 until N do
begin ANI := ANI + ABS(A[I, J]); BNI := BNI + ABS(B[I, J])
end; if ANI > ANORM then ANORM := ANI; if BNI > BNORM then
BNORM := BNI
end; if ANORM = 0 then ANORM := EPS; if BNORM = 0 then BNORM := EPS;
EPSA := EPS × ANORM; EPSB := EPS × BNORM;
for M := N, M while M ≥ 3 do
begin
for I := M + 1, I-1 while (if I > 1 then ABS(A[I, I-1]) > EPSA else
false) do Q := I-1;
if Q > 1 then A[Q, Q-1] := 0;
L: if Q ≥ M-1 then M := Q-1 else
begin
if ABS(B[Q, Q]) ≤ EPSB then
begin B[Q, Q] := 0; Q1 := Q + 1;
HSH2COL(Q, Q, N, Q, A[Q, Q], A[Q1, Q], A, B); A[Q1, Q] := 0;
Q := Q1; goto L
end else M1 := M-1; Q1 := Q + 1; CONST := 0.75; ITER[M] := ITER[M] + 1;
STATIONARY := if ITER[M] = 1 then true else
ABS(A[M, M-1]) ≥ CONST × OLD1 ∧ ABS(A[M-1, M-2]) ≥ CONST × OLD2;
if ITER[M] > 30 ∧ STATIONARY then
begin for I := 1 step 1 until M do ITER[I] := -1;
goto OUT
end;
if ITER[M] = 10 ∧ STATIONARY then
begin A10 := 0; A20 := 1; A30 := 1.1605
end else
begin B11 := B[Q, Q]; B22 := if ABS(B[Q1, Q1]) < EPSB then EPSB
else B[Q1, Q1];
B33 := if ABS(B[M1, M1]) < EPSB then EPSB else B[M1, M1];
B44 := if ABS(B[M, M]) < EPSB then EPSB else B[M, M] ;
A11 := A[Q, Q]/B11; A12 := A[Q, Q1]/B22; A21 := A[Q1, Q]/B11;
A22 := A[Q1, Q1]/B22; A33 := A[M1, M1]/B33; A34 := A[M1, M]/B44;
A43 := A[M, M1]/B33; A44 := A[M, M]/B44; B12 := B[Q, Q1]/B22;
B34 := B[M1, M]/B44;
A10 := ((A33-A11) × (A44-A11)-A34 × A43 + A43 × B34 × A11)/A21
+ A12-A11 × B12;
A20 := (A22-A11-A21 × B12)-(A33-A11)-(A44-A11) + A43 × B34;
A30 := A[Q + 2, Q1]/B22
end; OLD1 := ABS(A[M, M-1]); OLD2 := ABS(A[M-1, M-2]);
for K := Q step 1 until M1 do
begin K1 := K + 1; K2 := K + 2; K3 := if K + 3 > M then M else K + 3;
KM1 := if K-1 < Q then Q else K-1;
if K ≠ M1 then
begin if K = Q then
HSH3COL(KM1, KM1, N, K, A10, A20, A30, A, B) else
begin
HSH3COL(KM1, KM1, N, K, A[K, KM1], A[K1, KM1], A[K2, KM1], A, B);
A[K1, KM1] := A[K2, KM1] := 0
end;
HSH3ROW3(1, K3, N, K, B[K2, K2], B[K2, K1], B[K2, K], A, B, X);
B[K2, K] := B[K2, K1] := 0 ;
end else
begin HSH2COL(KM1, KM1, N, K, A[K, KM1], A[K1, KM1], A, B);
A[K1, KM1] := 0
end;
HSH2ROW3(1, K3, K3, N, K, B[K1, K1], B[K1, K], A, B, X); B[K1, K] := 0
end
end
end; OUT:
end QZIT;
procedure QZVAL(N, A, B, X, EPSA, EPSB, ALFR, ALFI, BETA); value N;
real EPSA, EPSB; integer N; array ALFR, ALFI, BETA, A, B, X;
begin integer M, L, J; real AN, BN, A11, A12, A21, A22, B11, B12, B22, E, C, D,
ER, EI, A11R, A11I, A12R, A12I, A21R, A21I, A22R, A22I, CZ, SZR, SZI,
CQ, SQR, SQI, SSR, SSI, TR, TI, BDR, BDI, R;
for M := N, M while M > 0 do
if (if M > 1 then A[M, M-1] = 0 else true) then
begin ALFR[M] := A[M, M]; BETA[M] := B[M, M]; ALFI[M] := 0; M := M-1
end else
begin L := M-1; if ABS(B[L, L]) ≤ EPSB then
begin B[L, L] := 0; HSH2COL(L, L, N, L, A[L, L], A[M, L], A, B);
A[M, L] := B[M, L] := 0; ALFR[L] := A[L, L]; ALFR[M] := A[M, M];
BETA[L] := B[L, L]; BETA[M] := B[M, M]; ALFI[M] := ALFI[L] := 0;
end else if ABS(B[M, M]) ≤ EPSB then
begin B[M, M] := 0; HSH2ROW3(1, M, M, N, L, A[M, M], A[M, L], A, B, X);
A[M, L] := B[M, L] := 0; ALFR[L] := A[L, L]; ALFR[M] := A[M, M];
BETA[L] := B[L, L]; BETA[M] := B[M, M]; ALFI[M] := ALFI[L] := 0;
end else
begin
AN := ABS(A[L, L]) + ABS(A[L, M]) + ABS(A[M, L]) + ABS(A[M, M]);
BN := ABS(B[L, L]) + ABS(B[L, M]) + ABS(B[M, M]);
A11 := A[L, L]/AN; A12 := A[L, M]/AN; A21 := A[M, L]/AN; A22 := A[M, M]/AN;
B11 := B[L, L]/BN; B12 := B[L, M]/BN; B22 := B[M, M]/BN;
E := A11/B11;
C := ((A22-E × B22)/B22-(A21 × B12)/(B11 × B22))/2;
D := C × C + (A21 × (A12-E × B12))/(B11 × B22);
if D ≥ 0 then
begin E := E + (if C < 0 then C-SQRT(D) else C + SQRT(D));
A11 := A11-E × B11; A12 := A12-E × B12; A22 := A22-E × B22;
if ABS(A11) + ABS(A12) ≥ ABS(A21) + ABS(A22) then
HSH2ROW3(1, M, M, N, L, A12, A11, A, B, X) else
HSH2ROW3(1, M, M, N, L, A22, A21, A, B, X);
if AN ≥ ABS(E) × BN then
HSH2COL(L, L, N, L, B[L, L], B[M, L], A, B) else
HSH2COL(L, L, N, L, A[L, L], A[M, L], A, B);
A[M, L] := B[M, L] := 0;
ALFR[L] := A[L, L]; ALFR[M] := A[M, M]; BETA[L] := B[L, L];
BETA[M] := B[M, M]; ALFI[M] := ALFI[L] := 0;
end else
begin
ER := E + C; EI := SQRT(-D); A11R := A11-ER × B11; A11I := EI × B11;
A12R := A12-ER × B12; A12I := EI × B12; A21R := A21; A21I := 0;
A22R := A22-ER × B22; A22I := EI × B22;
if ABS(A11R) + ABS(A11I) + ABS(A12R) + ABS(A12I) ≥
ABS(A21R) + ABS(A22R) + ABS(A22I) then
CHSH2(A12R, A12I, -A11R, -A11I, CZ, SZR, SZI) else
CHSH2(A22R, A22I, -A21R, -A21I, CZ, SZR, SZI);
if AN ≥ (ABS(ER) + ABS(EI)) × BN then
CHSH2(CZ × B11 + SZR × B12, SZI × B12, SZR × B22, SZI × B22, CQ, SQR, SQI)
else CHSH2(CZ × A11 + SZR × A12, SZI × A12, CZ × A21 + SZR × A22, SZI × A22,
CQ, SQR, SQI); SSR := SQR × SZR + SQI × SZI; SSI := SQR × SZI-SQI × SZR;
TR := CQ × CZ × A11 + CQ × SZR × A12 + SQR × CZ × A21 + SSR × A22;
TI := CQ × SZI × A12-SQI × CZ × A21 + SSI × A22;
BDR := CQ × CZ × B11 + CQ × SZR × B12 + SSR × B22;
BDI := CQ × SZI × B12 + SSI × B22;
R := SQRT(BDR × BDR + BDI × BDI); BETA[L] := BN × R;
ALFR[L] := AN × (TR × BDR + TI × BDI)/R;
ALFI[L] := AN × (TR × BDI-TI × BDR)/R;
TR := SSR × A11-SQR × CZ × A12-CQ × SZR × A21 + CQ × CZ × A22;
TI := -SSI × A11-SQI × CZ × A12 + CQ × SZI × A21;
BDR := SSR × B11-SQR × CZ × B12 + CQ × CZ × B22;
BDI := -SSI × B11-SQI × CZ × B12;
R := SQRT(BDR × BDR + BDI × BDI); BETA[M] := BN × R;
ALFR[M] := AN × (TR × BDR + TI × BDI)/R;
ALFI[M] := AN × (TR × BDI-TI × BDR)/R;
end
end; M := M-2
end
end QZVAL;
comment ================== 34602 ================= ;
procedure HSHDECMUL(N, A, B, DWARF); value N, DWARF; integer N;
real DWARF; array A, B;
begin array V[1:N]; integer J, K, K1, N1; real R, T, C;
real procedure TAMMAT(L, U, I, J, A, B); code 34014;
procedure HSHVECMAT(LR, UR, LC, UC, X, U, A); code 31070;
K := 1; N1 := N + 1;
for K1 := 2 step 1 until N1 do
begin R := TAMMAT(K1, N, K, K, B, B);
if R > DWARF then
begin R := if B[K, K] < 0 then -SQRT(R + B[K, K] × B[K, K])
else SQRT(R + B[K, K] × B[K, K]); T := B[K, K] + R; C := -T/R;
B[K, K] := -R; V[K] := 1;
for J := K1 step 1 until N do V[J] := B[J, K]/T;
HSHVECMAT(K, N, K1, N, C, V, B); HSHVECMAT(K, N, 1, N, C, V, A)
end; K := K1
end
end HSHDECMUL;
comment ================== 34603 ================= ;
procedure HESTGL3(N, A, B, X); value N; integer N; array A, B, X;
begin integer NM1, K, L, K1, L1;
procedure HSH2COL(LA, LB, U, I, A1, A2, A, B); code 34605;
procedure HSH2ROW3(L, UA, UB, UX, J, A1, A2, A, B, X); code 34607;
if N > 2 then
begin for K := 2 step 1 until N do
for L := 1 step 1 until K-1 do B[K, L] := 0;
NM1 := N-1; K := 1;
for K1 := 2 step 1 until NM1 do
begin L1 := N;
for L := N-1 step -1 until K1 do
begin
HSH2COL(K, L, N, L, A[L, K], A[L1, K], A, B); A[L1, K] := 0;
HSH2ROW3(1, N, L1, N, L, B[L1, L1], B[L1, L], A, B, X);
B[L1, L] := 0; L1 := L
end; K := K1
end
end
end HESTGL3;
comment ================== 34604 ================= ;
procedure HESTGL2(N, A, B); value N; integer N; array A, B;
begin integer NM1, K, L, K1, L1;
procedure HSH2COL(LA, LB, U, I, A1, A2, A, B); code 34605;
procedure HSH2ROW2(LA, LB, UA, UB, A1, A2, A, B); code 34608;
if N > 2 then
begin for K := 2 step 1 until N do
for L := 1 step 1 until K-1 do B[K, L] := 0;
NM1 := N-1; K := 1;
for K1 := 2 step 1 until NM1 do
begin L1 := N;
for L := N-1 step -1 until K1 do
begin
HSH2COL(K, L, N, L, A[L, K], A[L1, K], A, B); A[L1, K] := 0;
HSH2ROW2(1, 1, N, L1, L, B[L1, L1], B[L1, L], A, B);
B[L1, L] := 0; L1 := L
end; K := K1
end
end
end HESTGL2;
comment ================== 34605 ================= ;
procedure HSH2COL(LA, LB, U, I, A1, A2, A, B); value LA, LB, U, I, A1, A2;
integer LA, LB, U, I; real A1, A2; array A, B;
if A2 ≠ 0 then
begin real R, T, C; array V[I:I + 1];
procedure HSHVECMAT(LR, UR, LC, UC, X, U, A); code 31070;
R := if A1 < 0 then -SQRT(A1 × A1 + A2 × A2) else SQRT(A1 × A1 + A2 × A2);
T := A1 + R; C := -T/R; V[I] := 1; V[I + 1] := A2/T;
HSHVECMAT(I, I + 1, LA, U, C, V, A); HSHVECMAT(I, I + 1, LB, U, C, V, B)
end HSH2COL;
comment ================== 34606 ================= ;
procedure HSH3COL(LA, LB, U, I, A1, A2, A3, A, B);
value LA, LB, U, I, A1, A2, A3; integer LA, LB, I, U; real A1, A2, A3; array A, B;
if A2 ≠ 0 ∨ A3 ≠ 0 then
begin real R, T, C; array V[I:I + 2];
procedure HSHVECMAT(LR, UR, LC, UC, X, U, A); code 31070;
R := if A1 < 0 then -SQRT(A1 × A1 + A2 × A2 + A3 × A3)
else SQRT(A1 × A1 + A2 × A2 + A3 × A3);
T := A1 + R; C := -T/R; V[I] := 1; V[I + 1] := A2/T; V[I + 2] := A3/T;
HSHVECMAT(I, I + 2, LA, U, C, V, A); HSHVECMAT(I, I + 2, LB, U, C, V, B)
end HSH3COL;
comment ================== 34607 ================= ;
procedure HSH2ROW3(L, UA, UB, UX, J, A1, A2, A, B, X); value L, UA, UB, UX,
J, A1, A2; integer L, UA, UB, UX, J; real A1, A2; array A, B, X;
if A2 ≠ 0 then
begin real R, T, C; integer K; array V[J:J + 1];
procedure HSHVECTAM(LR, UR, LC, UC, X, U, A); code 31073;
R := if A1 < 0 then -SQRT(A1 × A1 + A2 × A2) else SQRT(A1 × A1 + A2 × A2);
T := A1 + R; C := -T/R; V[J + 1] := 1; V[J] := A2/T;
HSHVECTAM(L, UA, J, J + 1, C, V, A); HSHVECTAM(L, UB, J, J + 1, C, V, B);
HSHVECTAM(1, UX, J, J + 1, C, V, X)
end HSH2ROW3;
comment ================== 34608 ================= ;
procedure HSH2ROW2(LA, LB, UA, UB, J, A1, A2, A, B); value LA, LB, UA, UB,
J, A1, A2; integer LA, LB, UA, UB, J; real A1, A2; array A, B;
if A2 ≠ 0 then
begin real R, T, C; integer K; array V[J:J + 1];
procedure HSHVECTAM(LR, UR, LC, UC, X, U, A); code 31073;
R := if A1 < 0 then -SQRT(A1 × A1 + A2 × A2) else SQRT(A1 × A1 + A2 × A2);
T := A1 + R; C := -T/R; V[J + 1] := 1; V[J] := A2/T;
HSHVECTAM(LA, UA, J, J + 1, C, V, A); HSHVECTAM(LB, UB, J, J + 1, C, V, B)
end HSH2ROW2;
comment ================== 34609 ================= ;
procedure HSH3ROW3(L, U, UX, J, A1, A2, A3, A, B, X);
value L, U, UX, J, A1, A2, A3; integer L, J, U, UX; real A1, A2, A3; array A, B, X;
if A2 ≠ 0 ∨ A3 ≠ 0 then
begin real R, T, C; array V[J:J + 2]; integer K;
procedure HSHVECTAM(LR, UR, LC, UC, X, U, A); code 31073;
R := if A1 < 0 then -SQRT(A1 × A1 + A2 × A2 + A3 × A3)
else SQRT(A1 × A1 + A2 × A2 + A3 × A3);
T := A1 + R; C := -T/R; V[J + 2] := 1; V[J + 1] := A2/T; V[J] := A3/T;
HSHVECTAM(L, U, J, J + 2, C, V, A); HSHVECTAM(L, U, J, J + 2, C, V, B);
HSHVECTAM(L, UX, J, J + 2, C, V, X)
end HSH3ROW3;
comment ================== 34610 ================= ;
procedure HSH3ROW2(LA, LB, U, J, A1, A2, A3, A, B);
value LA, LB, U, J, A1, A2, A3; integer LA, LB, U, J; real A1, A2, A3; array A, B;
if A2 ≠ 0 ∨ A3 ≠ 0 then
begin real R, T, C; array V[J:J + 2];
procedure HSHVECTAM(LR, UR, LC, UC, X, U, A); code 31073;
R := if A1 < 0 then -SQRT(A1 × A1 + A2 × A2 + A3 × A3)
else SQRT(A1 × A1 + A2 × A2 + A3 × A3);
T := A1 + R; C := -T/R; V[J + 2] := 1; V[J + 1] := A2/T; V[J] := A3/T;
HSHVECTAM(LA, U, J, J + 2, C, V, A); HSHVECTAM(LB, U, J, J + 2, C, V, B)
end HSH3ROW2;
comment ================== 31070 ================= ;
procedure HSHVECMAT(LR, UR, LC, UC, X, U, A);
value LR, UR, LC, UC, X; integer LR, UR, LC, UC;
real X; array U, A;
begin real procedure TAMVEC(L, U, I, A, B); code 34012;
procedure ELMCOLVEC(L, U, I, A, B, X); code 34022;
for LC := LC step 1 until UC do
ELMCOLVEC(LR, UR, LC, A, U, TAMVEC(LR, UR, LC, A, U) × X)
end;
comment ================== 31071 ================= ;
procedure HSHCOLMAT(LR, UR, LC, UC, I, X, U, A);
value LR, UR, LC, UC, I, X; integer LR, UR, LC, UC, I;
real X; array U, A;
begin real procedure TAMMAT(L, U, I, J, A, B); code 34014;
procedure ELMCOL(L, U, I, J, A, B, X); code 34023;
for LC := LC step 1 until UC do
ELMCOL(LR, UR, LC, I, A, U, TAMMAT(LR, UR, LC, I, A, U) × X)
end;
comment ================== 31072 ================= ;
procedure HSHROWMAT(LR, UR, LC, UC, I, X, U, A);
value LR, UR, LC, UC, I, X; integer LR, UR, LC, UC, I;
real X; array U, A;
begin real procedure MATMAT(L, U, I, J, A, B); code 34013;
procedure ELMCOLROW(L, U, I, J, A, B, X); code 34029;
for LC := LC step 1 until UC do
ELMCOLROW(LR, UR, LC, I, A, U, MATMAT(LR, UR, I, LC, U, A) × X)
end;
comment ================== 31073 ================= ;
procedure HSHVECTAM(LR, UR, LC, UC, X, U, A);
value LR, UR, LC, UC, X; integer LR, UR, LC, UC;
real X; array U, A;
begin real procedure MATVEC(L, U, I, A, B); code 34011;
procedure ELMROWVEC(L, U, I, A, B, X); code 34027;
for LR := LR step 1 until UR do
ELMROWVEC(LC, UC, LR, A, U, MATVEC(LC, UC, LR, A, U) × X)
end;
comment ================== 31074 ================= ;
procedure HSHCOLTAM(LR, UR, LC, UC, I, X, U, A);
value LR, UR, LC, UC, I, X; integer LR, UR, LC, UC, I;
real X; array U, A;
begin real procedure MATMAT(L, U, I, J, A, B); code 34013;
procedure ELMROWCOL(L, U, I, J, A, B, X); code 34028;
for LR := LR step 1 until UR do
ELMROWCOL(LC, UC, LR, I, A, U, MATMAT(LC, UC, LR, I, A, U) × X)
end;
comment ================== 31075 ================= ;
procedure HSHROWTAM(LR, UR, LC, UC, I, X, U, A);
value LR, UR, LC, UC, I, X; integer LR, UR, LC, UC, I;
real X; array U, A;
begin real procedure MATTAM(L, U, I, J, A, B); code 34015;
procedure ELMROW(L, U, I, J, A, B, X); code 34024;
for LR := LR step 1 until UR do
ELMROW(LC, UC, LR, I, A, U, MATTAM(LC, UC, LR, I, A, U) × X)
end;
comment ================== 30006 ================= ;
real procedure PI;
PI := 3.14159265358979;
comment ================== 30007 ================= ;
real procedure E;
E := 2.71828182845905;
comment ================== 34410 ================= ;
procedure LNGVECVEC(L, U, SHIFT, A, B, C, CC, D, DD);
value L, U, SHIFT, C, CC; integer L, U, SHIFT;
real C, CC, D, DD; array A, B;
begin real E, EE;
procedure DPMUL(A, B, C, CC); code 31103;
procedure LNGADD(A, AA, B, BB, C, CC); code 31105;
for L := L step 1 until U do
begin DPMUL(A[L], B[L + SHIFT], E, EE);
LNGADD(C, CC, E, EE, C, CC)
end;
D := C; DD := CC
end LNGVECVEC;
comment ================== 34411 ================= ;
procedure LNGMATVEC(L, U, I, A, B, C, CC, D, DD);
value L, U, I, C, CC; integer L, U, I;
real C, CC, D, DD; array A, B;
begin real E, EE;
procedure DPMUL(A, B, C, CC); code 31103;
procedure LNGADD(A, AA, B, BB, C, CC); code 31105;
for L := L step 1 until U do
begin DPMUL(A[I, L], B[I], E, EE); LNGADD(C, CC, E, EE, C, CC)
end;
D := C; DD := CC
end LNGMATVEC;
comment ================== 34412 ================= ;
procedure LNGTAMVEC(L, U, I, A, B, C, CC, D, DD);
value L, U, I, C, CC; integer L, U, I;
real C, CC, D, DD; array A, B;
begin real E, EE;
procedure DPMUL(A, B, C, CC); code 31103;
procedure LNGADD(A, AA, B, BB, C, CC); code 31105;
for L := L step 1 until U do
begin DPMUL(A[L, I], B[I], E, EE); LNGADD(C, CC, E, EE, C, CC)
end;
D := C; DD := CC
end LNGTAMVEC;
comment ================== 34413 ================= ;
procedure LNGMATMAT(L, U, I, J, A, B, C, CC, D, DD);
value L, U, I, J, C, CC; integer L, U, I, J;
real C, CC, D, DD; array A, B;
begin real E, EE;
procedure DPMUL(A, B, C, CC); code 31103;
procedure LNGADD(A, AA, B, BB, C, CC); code 31105;
for L := L step 1 until U do
begin DPMUL(A[I, L], B[L, J], E, EE); LNGADD(C, CC, E, EE, C, CC)
end;
D := C; DD := CC
end LNGMATMAT;
comment ================== 34414 ================= ;
procedure LNGTAMMAT(L, U, I, J, A, B, C, CC, D, DD);
value L, U, I, J, C, CC; integer L, U, I, J;
real C, CC, D, DD; array A, B;
begin real E, EE;
procedure DPMUL(A, B, C, CC); code 31103;
procedure LNGADD(A, AA, B, BB, C, CC); code 31105;
for L := L step 1 until U do
begin DPMUL(A[L, I], B[L, J], E, EE); LNGADD(C, CC, E, EE, C, CC)
end;
D := C; DD := CC
end LNGTAMMAT;
comment ================== 34415 ================= ;
procedure LNGMATTAM(L, U, I, J, A, B, C, CC, D, DD);
value L, U, I, J, C, CC; integer L, U, I, J;
real C, CC, D, DD; array A, B;
begin real E, EE;
procedure DPMUL(A, B, C, CC); code 31103;
procedure LNGADD(A, AA, B, BB, C, CC); code 31105;
for L := L step 1 until U do
begin DPMUL(A[I, L], B[J, L], E, EE); LNGADD(C, CC, E, EE, C, CC)
end;
D := C; DD := CC
end LNGMATTAM;
comment ================== 34416 ================= ;
procedure LNGSEQVEC(L, U, IL, SHIFT, A, B, C, CC, D, DD);
value L, U, IL, SHIFT, C, CC; integer L, U, IL, SHIFT;
real C, CC, D, DD; array A, B;
begin real E, EE;
procedure DPMUL(A, B, C, CC); code 31103;
procedure LNGADD(A, AA, B, BB, C, CC); code 31105;
for L := L step 1 until U do
begin DPMUL(A[IL], B[L + SHIFT], E, EE); IL := IL + L;
LNGADD(C, CC, E, EE, C, CC)
end;
D := C; DD := CC
end LNGSEQVEC;
comment ================== 31507 ================= ;
procedure LNGFULSYMMATVEC(LR, UR, LC, UC, A, B, C);
value LR, UR, LC, UC, B; integer LR, UR, LC, UC;
array A, B, C;
begin real D, DD;
procedure LNGSYMMATVEC(L, U, I, A, B, C, CC, D, DD);
code 34418;
for LR := LR step 1 until UR do
begin LNGSYMMATVEC(LC, UC, LR, A, B, 0, 0, D, DD);
C[LR] := D + DD
end
end LNGFULSYMMATVEC;
comment ================== 31508 ================= ;
procedure LNGRESVEC(LR, UR, LC, UC, A, B, C, X);
value LR, UR, LC, UC, X; integer LR, UR, LC, UC;
real X; array A, B, C;
begin real D, DD, E, EE;
procedure DPMUL(X, Y, E, EE); code 31103;
procedure LNGMATVEC(L, U, I, A, B, C, CC, D, DD); code 34411;
for LR := LR step 1 until UR do
begin DPMUL(C[LR], X, E, EE);
LNGMATVEC(LC, UC, LR, A, B, E, EE, D, DD); C[LR] := D + DD
end
end LNGRESVEC;
comment ================== 31509 ================= ;
procedure LNGSYMRESVEC(LR, UR, LC, UC, A, B, C, X);
value LR, UR, LC, UC, B, X; integer LR, UR, LC, UC;
real X; array A, B, C;
begin real D, DD, E, EE;
procedure DPMUL(X, Y, E, EE); code 31103;
procedure LNGSYMMATVEC(L, U, I, A, B, C, CC, D, DD);
code 34418;
for LR := LR step 1 until UR do
begin DPMUL(C[LR], X, E, EE);
LNGSYMMATVEC(LC, UC, LR, A, B, E, EE, D, DD); C[LR] := D + DD
end
end LNGSYMRESVEC;
comment ================== 34357 ================= ;
procedure ROTCOMCOL(L, U, I, J, AR, AI, CR, CI, S);
value L, U, I, J, CR, CI, S; integer L, U, I, J;
real CR, CI, S; array AR, AI;
begin real ARLI, AILI, ARLJ, AILJ;
for L := L step 1 until U do
begin ARLI := AR[L, I]; AILI := AI[L, I]; ARLJ := AR[L, J];
AILJ := AI[L, J];
AR[L, I] := CR × ARLI + CI × AILI - S × ARLJ;
AI[L, I] := CR × AILI - CI × ARLI - S × AILJ;
AR[L, J] := CR × ARLJ - CI × AILJ + S × ARLI;
AI[L, J] := CR × AILJ + CI × ARLJ + S × AILI;
end
end ROTCOMCOL;
comment ================== 34358 ================= ;
procedure ROTCOMROW(L, U, I, J, AR, AI, CR, CI, S);
value L, U, I, J, CR, CI, S; integer L, U, I, J;
real CR, CI, S; array AR, AI;
begin real ARIL, AIIL, ARJL, AIJL;
for L := L step 1 until U do
begin ARIL := AR[I, L]; AIIL := AI[I, L]; ARJL := AR[J, L];
AIJL := AI[J, L];
AR[I, L] := CR × ARIL + CI × AIIL + S × ARJL;
AI[I, L] := CR × AIIL - CI × ARIL + S × AIJL;
AR[J, L] := CR × ARJL - CI × AIJL - S × ARIL;
AI[J, L] := CR × AIJL + CI × ARJL - S × AIIL;
end
end ROTCOMROW;
comment ================== 34611 ================= ;
procedure CHSH2(A1R, A1I, A2R, A2I, C, SR, SI);
value A1R, A1I, A2R, A2I; real A1R, A1I, A2R, A2I, C, SR, SI;
begin real R;
if A2R ≠ 0 ∨ A2I ≠ 0 then
begin if A1R ≠ 0 ∨ A1I ≠ 0 then
begin R := SQRT(A1R × A1R + A1I × A1I); C := R;
SR := (A1R × A2R + A1I × A2I)/R; SI := (A1R × A2I-A1I × A2R)/R;
R := SQRT(C × C + SR × SR + SI × SI); C := C/R; SR := SR/R; SI := SI/R
end else
begin SI := C := 0; SR := 1 end
end else begin C := 1; SR := SI := 0 end
end CHSH2;
comment ================== 33314 ================= ;
procedure NONLIN FEM LAG SKEW(X, Y, N, F, FY, FZ, NC, E);
integer N, NC;
real procedure F, FY, FZ;
array X, Y, E;
begin integer L, L1, IT;
real XL1, XL, H, A12, A21, B1, B2, TAU1, TAU2, CH, TL, G, YL, PP,
PLM, PRM, PL1, PL3, PL1PL2, PL1PL3, PL2PL2, PL2PL3,
PR1PR2, PR1PR3, PR2PR3, PL1QL2, PL1QL3, PL2QL1, PL2QL2, PL2QL3,
PL3QL1, PL3QL2, PR1QR2, PR1QR3, PR2QR1, PR2QR2, PR2QR3, PR3QR1,
PR3QR2, H2RM, ZL1, ZL, E1, E2, E3, E4, E5, E6, EPS, RHO;
array T, SUPER, SUB, CHI, GI[0:N-1], Z[0:N];
procedure DUPVEC(L, U, S, A, B); code 31030;
procedure ELEMENT MAT VEC EVALUATION 1;
begin real XM, VL, VR, WL, WR, PR, QM, RM, FM, XL12, XL1XL, XL2, ZM, ZACCM;
if NC = 0 then VL := VR := 0.5 else if NC = 1 then
begin VL := (XL1 × 2 + XL)/6; VR := (XL1 + XL × 2)/6 end else
begin XL12 := XL1 × XL1/12; XL1XL := XL1 × XL/6; XL2 := XL × XL/12;
VL := 3 × XL12 + XL1XL + XL2;
VR := 3 × XL2 + XL1XL + XL12
end;
WL := H × VL; WR := H × VR; PR := VR/(VL + VR);
XM := XL1 + H × PR; ZM := PR × ZL + (1 - PR) × ZL1;
ZACCM := (ZL - ZL1)/H ; QM := FZ(XM, ZM, ZACCM);
RM := FY(XM, ZM, ZACCM); FM := F(XM, ZM, ZACCM);
TAU1 := WL × RM; TAU2 := WR × RM;
B1 := WL × FM - ZACCM × (VL + VR); B2 := WR × FM + ZACCM × (VL + VR);
A12 := - (VL + VR)/H + VL × QM + (1 - PR) × PR × RM × (WL + WR);
A21 := - (VL + VR)/H - VR × QM + (1 - PR) × PR × RM × (WL + WR);
end ELEM. M.V. EV.;
procedure BOUNDARY CONDITIONS;
if L = 1 ∧ E2 = 0 then
begin TAU1 := 1; B1 := A12 := 0 end
else if L = 1 ∧ E2 ≠ 0 then
begin TAU1 := TAU1 - E1/E2
end else if L = N ∧ E5 = 0 then
begin TAU2 := 1; B2 := A21 := 0
end else if L = N ∧ E5 ≠ 0 then
begin TAU2 := TAU2 + E4/E5
end B.C.1;
procedure FORWARD BABUSKA;
if L = 1 then
begin CHI[0] := CH := TL := TAU1; T[0] := TL;
GI[0] := G := YL := B1; Y[0] := YL;
SUB[0] := A21; SUPER[0] := A12;
PP := A21/(CH - A12); CH := TAU2 - CH × PP;
G := B2 - G × PP; TL := TAU2; YL := B2
end else
begin CHI[L1] := CH := CH + TAU1;
GI[L1] := G := G + B1;
SUB[L1] := A21; SUPER[L1] := A12;
PP := A21/(CH - A12); CH := TAU2 - CH × PP;
G := B2 - G × PP; T[L1] := TL + TAU1; TL := TAU2;
Y[L1] := YL + B1; YL := B2
end FORWARD BABUSKA;
procedure BACKWARD BABUSKA;
begin PP := YL; Y[N] := G/CH;
G := PP; CH := TL; L := N;
for L := L - 1 while L ≥ 0 do
begin PP := SUPER[L]/(CH - SUB[L]);
TL := T[L]; CH := TL - CH × PP;
YL := Y[L]; G := YL - G × PP;
Y[L] := (GI[L] + G - YL)/(CHI[L] + CH - TL) ;
end
end BACKWARD BABUSKA;
DUPVEC(0, N, 0, Z, Y);
E1 := E[1]; E2 := E[2]; E3 := E[3]; E4 := E[4]; E5 := E[5]; E6 := E[6];
for IT := 1, IT + 1 while EPS > RHO do
begin L := 0; XL := X[0]; ZL := Z[0];
for L := L + 1 while L ≤ N do
begin XL1 := XL; L1 := L - 1; XL := X[L]; H := XL - XL1;
ZL1 := ZL; ZL := Z[L];
ELEMENT MAT VEC EVALUATION 1;
if L = 1 ∨ L = N then BOUNDARY CONDITIONS;
FORWARD BABUSKA
end;
BACKWARD BABUSKA;
EPS := 0; RHO := 1;
for L := 0 step 1 until N do
begin RHO := RHO + ABS(Z[L]);
EPS := EPS + ABS(Y[L]); Z[L] := Z[L] - Y[L]
end;
RHO := 10-14 × RHO
end;
DUPVEC(0, N, 0, Y, Z)
end NONLIN FEM LAG SKEW;