code 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 eqv 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 * .2763932022 50021 + K0 * .038196601125011) * H; K1:= FXY * H; X:= XL + .72360 6797749979 * H; Y:= YL + (ZL * .723606797749979 + K1 * .26180 3398874989) * 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 or 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 not LAST then D[2]:= H; D[3]:= X; D[4]:= Y; D[5]:= Z end RK3; eop