code 34430;
procedure QUANEWBND(N, LW, RW, X, F, JAC, FUNCT, IN, OUT);
value N, LW, RW; integer N, LW, RW;
array X, F, JAC, IN, OUT; boolean procedure FUNCT;
begin integer L, IT, FCNT, FMAX, ERR, B;
real MACHEPS, RELTOL, ABSTOL, TOLRES, ND, MZ, RES;
array DELTA[1:N];
real procedure EVALUATE(N, X, F); value N;
integer N; array X, F;
begin FCNT:= FCNT + N; if ^ FUNCT(N, 1, N, X, F) then
begin ERR:= 2; goto EXIT end;
if FCNT > FMAX then ERR:= 1;
EVALUATE:= SQRT(VECVEC(1, N, 0, F, F))
end EVAL;
boolean procedure DIRECTION;
begin array LU[1:L], AUX[1:5]; AUX[2]:= MACHEPS;
MULVEC(1, N, 0, DELTA, F, -1); DUPVEC(1, L, 0, LU, JAC);
DECSOLBND(LU, N, LW, RW, AUX, DELTA);
DIRECTION:= AUX[3] = N
end SOLLINSYS;
boolean procedure TEST(ND, TOLD, NRES, TOLRES, ERR);
value ND, TOLD; integer ERR; real ND, TOLD, NRES, TOLRES;
TEST:= ERR ^= 0 or (NRES < TOLRES and ND < TOLD);
procedure UPDATE JAC;
begin integer I, J, K, R, M; real MUL, CRIT;
array PP, S[1:N];
CRIT:= ND * MZ;
for I:= 1 step 1 until N do PP[I]:= DELTA[I] ** 2;
R:= 1; K:= 1; M:= RW + 1;
for I:= 1 step 1 until N do
begin MUL:= 0; for J:= R step 1 until M do
MUL:= MUL + PP[J]; J:= R - K;
if ABS(MUL) > CRIT then
ELMVEC(K, M - J, J, JAC, DELTA, F[I] / MUL); K:= K + B;
if I > LW then R:= R + 1 else K:= K - 1;
if M < N then M:= M + 1
end
end UPDATEJAC
MACHEPS:= IN[0]; RELTOL:= IN[1]; ABSTOL:= IN[2];
TOLRES:= IN[3]; FMAX:= IN[4]; MZ:= MACHEPS ** 2;
IT:= FCNT:= 0; B:= LW + RW; L:= (N - 1) * B + N; B:= B + 1;
RES:= SQRT(VECVEC(1, N, 0, F, F)); ERR:= 0;
ITERATE: if ^ TEST(SQRT(ND), SQRT(VECVEC(1, N, 0, X, X)) * RELTOL
+ ABSTOL, RES, TOLRES, ERR) then
begin IT:= IT + 1; if IT ^= 1 then UPDATEJAC;
if ^ DIRECTION then ERR:= 3 else
begin ELMVEC(1, N, 0, X, DELTA, 1);
ND:= VECVEC(1, N, 0, DELTA, DELTA);
RES:= EVALUATE(N, X, F); goto ITERATE
end
end;
EXIT: OUT[1]:= SQRT(ND); OUT[2]:=RES; OUT[3]:= FCNT;
OUT[4]:= IT; OUT[5]:= ERR
end QUANEWBND;
eop