code 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;
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
eop