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