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