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;
goto 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;
goto 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;
goto 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 goto 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;
goto CHECK ADD;
end;
end else if RECURS MAXRECURS then goto 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 goto ADD LOOP;
SUMUP := SUM;
goto 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 
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 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 XDIR then H else H ZL) < 0 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 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 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 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 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 .276393202250021 + K0 .038196601125011) H;
K1 := FXY H;
X := XL + .723606797749979 H;
Y := YL + (ZL .723606797749979 + K1 .261803398874989) 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 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 + .276393202250021 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] .001699155839840) 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] .301502832395825 + 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 - .693147180559945);
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] := -.283876542276024;
B[2] := -.076852840844786;
B[3] := +.001706305071096;
B[4] := +.001271927136655;
B[5] := +.000076309597586;
B[6] := -.000004971736704;
B[7] := -.000000865920800;
B[8] := -.000000033126120;
B[9] := +.000000001745136;
B[10] := +.000000000242310;
B[11] := +.000000000009161;
B[12] := -.000000000000170;
X2 := X X 8;
ALFA := -.000000000000001;
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 + .921870293650453;
ALFA := -.000000000000034;
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.14159265358979;
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.14159265358979 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 + .918938533204672 + (((.59523809523809510-3 X2 + .79365079365079410-3) X2 + .27777777777777810-2) X2 + .83333333333333310-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] := -.0761141616704358;
B[2] := +.0084323249659328;
B[3] := -.0010794937263286;
B[4] := +.0001490074800369;
B[5] := -.0000215123998886;
B[6] := +.0000031979329861;
B[7] := -.0000004851693012;
B[8] := +.0000000747148782;
B[9] := -.0000000116382967;
B[10] := +.0000000018294004;
B[11] := -.0000000002896918;
B[12] := +.0000000000461570;
B[13] := -.0000000000073928;
B[14] := +.0000000000011894;
B[15] := -.0000000000001921;
B[16] := +.0000000000000311;
B[17] := -.0000000000000051;
B[18] := +.0000000000000008;
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 + .491415393029387 - 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 procedureONE_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.35609843701815410-1 C + 0.69963834886191410+1) C + 0.21979261618294210+2) C + 0.24266795523053210+3;
Q := ((C + 0.15082797630407810+2) C + 0.91164905404514910+2) C + 0.21505887586986110+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.13686485738271710-6 C + 0.56419551747897410+0) C + 0.72117582508830910+1) C + 0.43162227222056710+2) C + 0.15298928504694010+3) C + 0.33932081673434410+3) C + 0.45191895371187310+3) C + 0.30045926102016210+3;
Q := ((((((C + 0.12782727319629410+2) C + 0.77000152935229510+2) C + 0.27758544474398810+3) C + 0.63898026446563110+3) C + 0.93135409485061010+3) C + 0.79095092532789810+3) C + 0.30045926095698310+3;
NONEXPERFC := if X > 0 then P ÷ Q else EXP(X X) 2 - P ÷ Q;
end else begin;
C := 1 ÷ X ÷ X;
P := (((0.22319245973418510-1 C + 0.27866130860964810-0) C + 0.22695659353968710-0) C + 0.49473091062325110-1) C + 0.29961070770354210-2;
Q := (((C + 0.19873320181713510+1) C + 0.10516751070679310+1) C + 0.19130892610783010+0) C + 0.10620923052846810-1;
C := (C (-P) ÷ Q + 0.564189583547756) ÷ 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.4771138568268710-6 X4 - 5.2807965137262310-4) X4 + 1.7619395254349110-2) X4 - 1.9946089882618410-1) X4 + 1;
Q := (((1.1893890142287610-7 X4 + 1.5523788527699410-5) X4 + 1.0995721502564210-3) X4 + 4.7279211201045310-2) X4 + 1;
C := X P ÷ Q;
P := (((6.7174846662514110-7 X4 - 8.4555728435277710-5) X4 + 3.8778212346368310-3) X4 - 7.0748991514452310-2) X4 + 5.2359877559829910-1;
Q := (((5.9528122767841010-8 X4 + 9.6269087593903410-6) X4 + 8.1709194215213410-4) X4 + 4.1122315114238410-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.6829331012187110-8 X4 + 1.0236543505610610-5) X4 - 6.7137603469492210-4) X4 + 1.9187027943174710-2) X4 - 2.0707336033532410-1) X4 + 1.0000000000011110+0;
Q := ((((4.4170137406501010-10 X4 + 8.7794537789236910-8) X4 + 1.0134463086674910-5) X4 + 7.8890524505236010-4) X4 + 3.9666749695232310-2) X4 + 1;
C := X P ÷ Q;
P := ((((-5.7676581559308910-9 X4 + 1.2853104374272510-6) X4 - 1.0954002391143510-4) X4 + 4.3073052650436710-3) X4 - 7.3776691401019110-2) X4 + 5.2359877559834410-1;
Q := ((((2.0553912445858010-10 X4 + 5.0309058124661210-8) X4 + 6.8708626571862010-6) X4 + 6.1822462019547310-4) X4 + 3.5339834276747210-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.57079632679490;
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.57079632679490;
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.3530423554038810+1 C4 + 6.9853426160102110+1) C4 + 4.8034065557792510+1) C4 + 8.0358812280394210+0) C4 + 3.1830926850490610-1;
Q := (((6.5563064008391610+1 C4 + 2.4956199380517210+2) C4 + 1.5761100558012310+2) C4 + 2.5549161843579510+1) C4 + 1;
F := XINV P ÷ Q;
P := ((((2.0542143249850110+1 C4 + 1.9623203797166310+2) C4 + 1.9918281867890310+2) C4 + 5.3112281348098910+1) C4 + 4.4453382755051210+0) C4 + 1.0132061881027510-1;
Q := ((((1.0137948339600310+3 C4 + 3.4811214785654510+3) C4 + 2.5447313318182210+3) C4 + 5.8359057571642910+2) C4 + 4.5392501967368910+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.1770324936514010+2 C4 + 3.0914516157443010+3) C4 + 1.9300764078671610+3) C4 + 3.3983713492698410+2) C4 + 1.9588394102196910+1) C4 + 3.1830988182201710-1;
Q := ((((3.3612169918055110+3 C4 + 1.0933424898880910+4) C4 + 6.3374715585114410+3) C4 + 1.0853506750065010+3) C4 + 6.1842713817288710+1) C4 + 1;
F := XINV P ÷ Q;
P := ((((3.1333016306875610+2 C4 + 1.5926800608535410+3) C4 + 9.0831174952959410+2) C4 + 1.4095961791131610+2) C4 + 7.1120500178978310+0) C4 + 1.0132116176180510-1;
Q := ((((1.1514983237626110+4 C4 + 2.4131556721337010+4) C4 + 1.0672967803058110+4) C4 + 1.4905192279732910+3) C4 + 7.1712859693930210+1) C4 + 1;
G := X3INV P ÷ Q;
end else begin;
XINV := 1 ÷ X;
A := XINV XINV;
X3INV := A XINV;
C4 := A A;
P := ((((2.6129475322514210+4 C4 + 6.1354711361470010+4) C4 + 1.3492202817185710+4) C4 + 8.1634340178437510+2) C4 + 1.6479771284124610+1) C4 + 9.6754603296709010-2;
Q := ((((1.3701236481722610+6 C4 + 1.0010547890079110+6) C4 + 1.6594646262185310+5) C4 + 9.0182759623152410+3) C4 + 1.7387169067364910+2) C4 + 1;
F := (C4 (-P) ÷ Q + 0.318309886183791) XINV;
P := (((((1.7259022465483710+6 C4 + 6.6690706166863610+6) C4 + 1.7775895083803010+6) C4 + 1.3567886781375610+5) C4 + 3.8775414174637810+3) C4 + 4.3171015782335810+1) C4 + 1.5398973381976910-1;
Q := (((((1.4062244112358010+8 C4 + 9.3869586253163510+7) C4 + 1.6209560050023210+7) C4 + 1.0287869305668810+6) C4 + 2.6918318039624310+4) C4 + 2.8673319497589910+2) C4 + 1;
G := (C4 (-P) ÷ Q + 0.101321183642338) 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.355028053887817;
C2 := 0.258819403792807;
XX[1] := 1.408308107218096410+1;
XX[2] := 1.021488547919733110+1;
XX[3] := 7.4416018450450930;
XX[4] := 5.3070943061781927;
XX[5] := 3.6340135029132462;
XX[6] := 2.3310652303052450;
XX[7] := 1.3447970824609268;
XX[8] := 6.418885836956729610-1;
XX[9] := 2.010034599812104610-1;
XX[10] := 8.059435917205283310-3;
WW[1] := 3.154251576296478710-14;
WW[2] := 6.639421081958492110-11;
WW[3] := 1.758388906134566910-8;
WW[4] := 1.371239237043581510-6;
WW[5] := 4.435096663928435010-5;
WW[6] := 7.155501091771825510-4;
WW[7] := 6.488956610333538110-3;
WW[8] := 3.644041587577328210-2;
WW[9] := 1.439979241859099910-1;
WW[10] := 8.123114133626148610-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.666666666666667 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.17809724509617 else -3.53429173528852;
comment R := "IF" D = 0 "OR" 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.71238898038469;
comment R := R + 3 * PI / 2
;
ZZ := R R;
ZAJ := if I = 1 D = 1 then -1.01879297 else if I = 1 D = 2 then -1.17371322 else R 0.666666666666667 (if A then -(1 + (5 ÷ 48 - (5 ÷ 36 - (77125 ÷ 82944 - (108056875 ÷ 6967296 - (162375596875 ÷ 334430208) ÷ ZZ) ÷ ZZ) ÷ ZZ) ÷ ZZ) ÷ ZZ) else -(1 - (7 ÷ 48 - (35 ÷ 288 - (181223 ÷ 207360 - (18683371 ÷ 1244160 - (91145884361 ÷ 191102976) ÷ 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;