|
|
The following program was used to explore the estimated catastrophe models
that are program catastrophe (input, output, Image1, Image2, Image3); const minwidth = 15; maxsize = 1000; maxbig = 32000; f1name = 'ImageLyap'; f2name = 'ImageSum'; f3name = 'ImagePower'; ps1name = 'PScatcode'; matnn = 5; matnnn = 20; inc = 0.001; vv2 = 2048; nnpp = 9000; gleft = 680; gtop = 460; gright = 1080; gbottom = 860; type HugePtr = ^BigArray; BigArray = array[1..200, 1..200] of real; HugePtr2 = ^BigArray2; BigArray2 = array[1..maxbig, 1..matnn] of real; HugePtr3 = ^BigArray3; BigArray3 = array[1..10000] of real; GraphPtr = ^GraphBig; GraphBig = array[1..maxbig, 1..matnn] of real; RealArrayVV2 = array[1..vv2] of real; RealArrayVV3 = array[1..1025, 1..2] of real; RealArrayNP = array[1..nnpp] of real; var dim, c1, c2, d1, d2, iter, iternum, toss, lyap, kitu, limit, multiplier, lagg, again, limits: integer; x1low, x1high, x2low, x2high, perspect, shift, mold, w1, acc, x1dlow, x1dhigh, x2dlow, x2dhigh: real; lx1, ux1, lx2, ux2, xprim, lowp1, lowp2, highp1, highp2, rDR, timeone, expand, pi: real; min2, max2, min3, max3, context: real; ff1, ff2, ff3, ps1: text; row, col, ticker, ticker2, ticker3, graphtype, traject, sasa, year, method, highlite: integer; nn, nnn, eqnum, laggedid, count, item, anza, graphonly, series, cross, psprint: integer; suppress, connect, condques, rotation, angle: integer; filein: text; y: HugePtr2; yy: HugePtr2; p: array[1..20] of real; pp: array[1..20] of real; party: array[1..4] of integer; image1: HugePtr; image2: HugePtr; image3: HugePtr; newx: GraphPtr; fourdata: RealArrayVV2; spectral: RealArrayVV3; xone: array[1..1000] of real; xlag: HugePtr3; mx: array[1..matnnn] of real; x: array[1..matnnn] of real; znorm: array[1..matnn] of real; gsc: array[1..matnn] of real; cum: array[1..matnn] of real; xnew: array[1..matnnn] of real; finame: string; r: Rect; r2: Rect; procedure initialize; begin r.left := 0; r.top := 50; r.right := 640; r.bottom := 460; SetTextRect(r); r2.left := gleft; r2.top := gtop; r2.right := gright; r2.bottom := gbottom; SetDrawingRect(r2); new(y); new(yy); new(newx); ticker2 := 0; laggedid := 0; pi := 3.141549; end; procedure condition; begin p[2] := p[2] + (pp[2] * w1); p[4] := p[4] + (pp[4] * w1); p[5] := p[5] + (pp[5] * w1); p[6] := p[6] + (pp[6] * w1); p[7] := p[7] + (pp[7] * w1); p[8] := p[8] + (pp[8] * w1); p[9] := p[9] + (pp[9] * w1); p[19] := p[19] + (pp[19] * w1); end; procedure parm1; begin p[2] := 0; p[4] := 0.66407; p[5] := -0.42078; p[6] := 0.34843; p[7] := 0.71071; p[8] := 0.12868; p[9] := 0.19019; p[19] := 0.14762; pp[4] := 0.81578; pp[5] := 0.09054; pp[6] := 0.10649; pp[7] := 0.99656; pp[8] := 0.20632; pp[9] := 0.48091; pp[19] := -1.02490; lowp1 := 0 - expand; highp1 := 0.42 + expand; x1low := -10.0; x1high := 15.0; x1dlow := 0.5; x1dhigh := 1.0; x2dlow := 0.0; x2dhigh := 0.78; x2low := 0.0 - expand; x2high := 0.78 + expand; condition; end; procedure parm2; begin p[2] := 0; p[4] := 1.20418; p[5] := -0.51405; p[6] := 0.15501; p[7] := 1.13798; p[8] := 0.20683; p[9] := 0.19554; p[19] := -0.50866; pp[4] := 0.12824; pp[5] := -0.02477; pp[6] := -0.00479; pp[7] := -0.06923; pp[8] := -0.49641; pp[9] := 0.49962; pp[19] := 0.10608; lowp1 := 0 - expand; highp1 := 0.7566 + expand; x1low := -10.0; x1high := 15.0; x1dlow := 0.4; x1dhigh := 1.0; x2dlow := 0.0; x2dhigh := 0.65; x2low := 0.0 - expand; x2high := 0.65 + expand; condition; end; procedure parm3; begin p[2] := 1; p[5] := 5.98186; p[6] := 0.83441; p[7] := 1.03085; p[8] := 0.88157; p[9] := 0.41774; p[10] := -0.13497; p[11] := 1.24597; if (condques = 1) then context := 0; {Republican standardized} if (condques = 2) then begin context := 2; pp[5] := -0.00334; pp[6] := -0.04221; pp[7] := 0.00608; pp[8] := -0.09321; pp[9] := -0.06038; pp[10] := -0.11694; pp[11] := -0.01458; end; {Democratic standardized} if (condques = 3) then begin context := 2.7; pp[5] := 0.001897; pp[6] := 0.008622; pp[7] := -0.006862; pp[8] := 0.052890; pp[9] := 0.066099; pp[10] := 0.078435; pp[11] := 0.043908; end; {Neighbor -3R, 0M, and 3D} if (condques = 4) then begin context := 3; pp[5] := 0.20720; pp[6] := 0.07340; pp[7] := -0.26706; pp[8] := 0.03561; pp[9] := -0.04350; pp[10] := 0.01784; pp[11] := 0.04216; end; {Rae's F nonstandardized} if (condques = 5) then begin context := 3; pp[5] := -0.002982; pp[6] := -0.000475; pp[7] := 0.007336; pp[8] := 0.015913; pp[9] := 0.036962; pp[10] := -0.018868; pp[11] := 0.022124; {standardized} context := 2.4; context := -3.7; pp[5] := -0.00245; pp[6] := -0.11443; pp[7] := -0.03304; pp[8] := -0.10406; pp[9] := -0.02834; pp[10] := -0.16631; pp[11] := -0.03693; end; end; function lag (lagvar: real): real; var iii: integer; begin if (ticker3 = 1) then begin for iii := 1 to lagg do begin xlag^[iii] := lagvar; end; lag := lagvar; end; if (ticker3 > 1) then begin for iii := (lagg - 1) downto 1 do begin xlag^[(lagg - iii)] := xlag^[(lagg - iii + 1)]; end; xlag^[(lagg)] := lagvar; lag := xlag^[1]; end; end; function power (base: real; exponent: integer): real; var tempvar: real; t: integer; begin tempvar := base; if (exponent > 1) then begin for t := 1 to (exponent - 1) do begin tempvar := tempvar * base; end; end; if (exponent < 0) then begin tempvar := 1 / base; for t := 1 to (abs(exponent) - 1) do begin tempvar := tempvar * (1 / base); end; end; if (exponent = 0) then tempvar := 1; power := tempvar; end; function powernoint (base: real; exponent: real): real; begin powernoint := exp(ln(base) * exponent); end; function eq1: real; var w1, w2: real; begin if (kitu = 1) then eq1 := (p[2] * (power(mx[1], 3))) - (p[1] * mx[1]) + (p[3] * mx[2]); if (kitu = 2) then eq1 := (p[2] * (power((mx[1] - 1), 3))) + (p[1] * (mx[1] - 1)) - (p[3] * (mx[2] - 1)); if (kitu = 3) then eq1 := ((p[2] * (power((mx[1] - 1), 3))) + (p[1] * (mx[1] - 1)) - (p[3] * (mx[2] - 1))) * (1 - mx[1]) * mx[1]; if (kitu = 4) then eq1 := (p[19] * mx[2]) - (p[4] * mx[2] * p[1]) + (p[5] * (p[6] * (mx[1] - p[7]))) + (p[8] * (power((p[6] * (mx[1] - p[7])), 2))) + (p[9] * (power((p[6] * (mx[1] - p[7])), 3))); {eq1 := (p[19] * mx[2]) - (p[4] * mx[2] * p[1]) + (p[5] * (p[6] * (mx[1] - p[7]))) + (p[8] * (power((p[6] * (mx[1] - p[7])), 2))) + (p[9] * (power((p[6] * (mx[1] - p[7])), 3)));} if (kitu = 5) then begin {set p5=0 to get the plane, 1 otherwise.} w1 := (1 + mx[2] - p[1]) / 2; w2 := (mx[2] + p[1]) / 2; eq1 := (p[5] * (p[2] * w2 * (1 - w2) * (mx[1] - p[4]) - (p[3] * power(mx[1] - p[4], 3))) + (p[6] * w1)) - mx[1]; {eq1 := (p[5] * (p[2] * (mx[1] - p[4]) - (p[3] * power(mx[1] - p[4], 3))) + w1)-mx[1];} {eq1 := (p[5] * (p[2] * w2 * (mx[1] - p[4]) - (p[3] * power(mx[1] - p[4], 3))) + w1) - mx[1];} {eq1 := (p[5] * (p[2] * (1 - w2) * (mx[1] - p[4]) - (p[3] * power(mx[1] - p[4], 3))) + w1)-mx[1];} end; if (kitu = 6) then begin w1 := (1 + mx[2] - p[1]) / 2; w2 := (mx[2] + p[1]) / 2; eq1a := (p[9] + (pp[9] * context)) * ((((p[5] + pp[5] * context) * ((p[10] + (pp[10] * context)) + w2) * (1 - (p[11] + (pp[11] * context)) * w2) * (mx[1] - (p[6] + (pp[6] * context)))); eq1 := eq1a - ((p[7] + pp[7] * context) * ((power(mx[1] - (p[6] + (pp[6] * context)), 3)))) + ((p[8] + (pp[8] * context)) * w1)) - mx[1]); end; end; function eq2: real; begin end; function eq3: real; begin end; function eq4: real; begin end; function fx (xx: real): real; begin mx[1] := xx; fx := eq1; end; function par1x1: real; var it1, it2: real; begin mx[1] := mx[1] - inc; if (laggedid = 1) then mold := mold - inc; it1 := eq1; mx[1] := mx[1] + (2 * inc); if (laggedid = 1) then mold := mold + (2 * inc); it2 := eq1; par1x1 := (it2 - it1) / (2 * inc); mx[1] := mx[1] - inc; if (laggedid = 1) then mold := mold - inc; end; function par1x2: real; var it1, it2: real; begin mx[2] := mx[2] - inc; if (laggedid = 2) then mold := mold - inc; it1 := eq1; mx[2] := mx[2] + (2 * inc); if (laggedid = 2) then mold := mold + (2 * inc); it2 := eq1; par1x2 := (it2 - it1) / (2 * inc); mx[2] := mx[2] - inc; if (laggedid = 2) then mold := mold - inc; end; function par1x3: real; var it1, it2: real; begin mx[3] := mx[3] - inc; if (laggedid = 3) then mold := mold - inc; it1 := eq1; mx[3] := mx[3] + (2 * inc); if (laggedid = 3) then mold := mold + (2 * inc); it2 := eq1; par1x3 := (it2 - it1) / (2 * inc); mx[3] := mx[3] - inc; if (laggedid = 3) then mold := mold - inc; end; function par1x4: real; var it1, it2: real; begin mx[4] := mx[4] - inc; if (laggedid = 4) then mold := mold - inc; it1 := eq1; mx[4] := mx[4] + (2 * inc); if (laggedid = 4) then mold := mold + (2 * inc); it2 := eq1; par1x4 := (it2 - it1) / (2 * inc); mx[4] := mx[4] - inc; if (laggedid = 4) then mold := mold - inc; end; function par2x1: real; var it1, it2: real; begin mx[1] := mx[1] - inc; if (laggedid = 1) then mold := mold - inc; it1 := eq2; mx[1] := mx[1] + (2 * inc); if (laggedid = 1) then mold := mold + (2 * inc); it2 := eq2; par2x1 := (it2 - it1) / (2 * inc); mx[1] := mx[1] - inc; if (laggedid = 1) then mold := mold - inc; end; function par2x2: real; var it1, it2: real; begin mx[2] := mx[2] - inc; if (laggedid = 2) then mold := mold - inc; it1 := eq2; mx[2] := mx[2] + (2 * inc); if (laggedid = 2) then mold := mold + (2 * inc); it2 := eq2; par2x2 := (it2 - it1) / (2 * inc); mx[2] := mx[2] - inc; if (laggedid = 2) then mold := mold - inc; end; function par2x3: real; var it1, it2: real; begin mx[3] := mx[3] - inc; if (laggedid = 3) then mold := mold - inc; it1 := eq2; mx[3] := mx[3] + (2 * inc); if (laggedid = 3) then mold := mold + (2 * inc); it2 := eq2; par2x3 := (it2 - it1) / (2 * inc); mx[3] := mx[3] - inc; if (laggedid = 3) then mold := mold - inc; end; function par2x4: real; var it1, it2: real; begin mx[4] := mx[4] - inc; if (laggedid = 4) then mold := mold - inc; it1 := eq2; mx[4] := mx[4] + (2 * inc); if (laggedid = 4) then mold := mold + (2 * inc); it2 := eq2; par2x4 := (it2 - it1) / (2 * inc); mx[4] := mx[4] - inc; if (laggedid = 4) then mold := mold - inc; end; function par3x1: real; var it1, it2: real; begin mx[1] := mx[1] - inc; if (laggedid = 1) then mold := mold - inc; it1 := eq3; mx[1] := mx[1] + (2 * inc); if (laggedid = 1) then mold := mold + (2 * inc); it2 := eq3; par3x1 := (it2 - it1) / (2 * inc); mx[1] := mx[1] - inc; if (laggedid = 1) then mold := mold - inc; end; function par3x2: real; var it1, it2: real; begin mx[2] := mx[2] - inc; if (laggedid = 2) then mold := mold - inc; it1 := eq3; mx[2] := mx[2] + (2 * inc); if (laggedid = 2) then mold := mold + (2 * inc); it2 := eq3; par3x2 := (it2 - it1) / (2 * inc); mx[2] := mx[2] - inc; if (laggedid = 2) then mold := mold - inc; end; function par3x3: real; var it1, it2: real; begin mx[3] := mx[3] - inc; if (laggedid = 3) then mold := mold - inc; it1 := eq3; mx[3] := mx[3] + (2 * inc); if (laggedid = 3) then mold := mold + (2 * inc); it2 := eq3; par3x3 := (it2 - it1) / (2 * inc); mx[3] := mx[3] - inc; if (laggedid = 3) then mold := mold - inc; end; function par3x4: real; var it1, it2: real; begin mx[4] := mx[4] - inc; if (laggedid = 4) then mold := mold - inc; it1 := eq3; mx[4] := mx[4] + (2 * inc); if (laggedid = 4) then mold := mold + (2 * inc); it2 := eq3; par3x4 := (it2 - it1) / (2 * inc); mx[4] := mx[4] - inc; if (laggedid = 4) then mold := mold - inc; end; function par4x1: real; var it1, it2: real; begin mx[1] := mx[1] - inc; if (laggedid = 1) then mold := mold - inc; it1 := eq4; mx[1] := mx[1] + (2 * inc); if (laggedid = 1) then mold := mold + (2 * inc); it2 := eq4; par4x1 := (it2 - it1) / (2 * inc); mx[1] := mx[1] - inc; if (laggedid = 1) then mold := mold - inc; end; function par4x2: real; var it1, it2: real; begin mx[2] := mx[2] - inc; if (laggedid = 2) then mold := mold - inc; it1 := eq4; mx[2] := mx[2] + (2 * inc); if (laggedid = 2) then mold := mold + (2 * inc); it2 := eq4; par4x2 := (it2 - it1) / (2 * inc); mx[2] := mx[2] - inc; if (laggedid = 2) then mold := mold - inc; end; function par4x3: real; var it1, it2: real; begin mx[3] := mx[3] - inc; if (laggedid = 3) then mold := mold - inc; it1 := eq4; mx[3] := mx[3] + (2 * inc); if (laggedid = 3) then mold := mold + (2 * inc); it2 := eq4; par4x3 := (it2 - it1) / (2 * inc); mx[3] := mx[3] - inc; if (laggedid = 3) then mold := mold - inc; end; function par4x4: real; var it1, it2: real; begin mx[4] := mx[4] - inc; if (laggedid = 4) then mold := mold - inc; it1 := eq4; mx[4] := mx[4] + (2 * inc); if (laggedid = 4) then mold := mold + (2 * inc); it2 := eq4; par4x4 := (it2 - it1) / (2 * inc); mx[4] := mx[4] - inc; if (laggedid = 4) then mold := mold - inc; end; procedure initnums; begin count := 0; ticker := 0; end; procedure post1; begin writeln(ps1, '150 250 translate'); writeln(ps1, '1 setlinewidth'); writeln(ps1, '/Times-Bold findfont 15 scalefont setfont'); writeln(ps1, '1 setlinejoin'); end; procedure post2; begin writeln(ps1, 'stroke showpage'); end; procedure graph; var k, j, width, height, transx1, transx2, switch, kwisha, fourmax, transform, diam: integer; minx1, minx2, maxx1, maxx2, miny1, miny2, maxy1, maxy2, miny3, maxy3, axedraw1, axedraw2: real; axeminx, axemaxx, axeminy, axemaxy, scale, labset, transx3, transx4, phi, scale1, scale2, scale3: real; axedraw: array[1..3, 1..2] of real; begin width := gright - gleft; height := gbottom - gtop; labset := 0.05; anza := 1; multiplier := count + 1; kwisha := multiplier + 7 + 6 + 3 + 1; EraseRect(0, 0, 400, 400); for k := anza to (multiplier - 1) do begin if (k = anza) then begin miny1 := y^[anza, 1]; maxy1 := y^[anza, 1]; miny2 := y^[anza, 2]; maxy2 := y^[anza, 2]; miny3 := y^[anza, 3]; maxy3 := y^[anza, 3]; end; if (k > anza) then begin if (y^[k, 1] < miny1) then miny1 := y^[k, 1]; if (y^[k, 1] > maxy1) then maxy1 := y^[k, 1]; if (y^[k, 2] < miny2) then miny2 := y^[k, 2]; if (y^[k, 2] > maxy2) then maxy2 := y^[k, 2]; if (y^[k, 3] < miny3) then miny3 := y^[k, 3]; if (y^[k, 3] > maxy3) then maxy3 := y^[k, 3]; end; end; {Use the next two lines to set the maximum and minimum values for the vertical axis.} {maxy1 := 1;} {miny1 := 0;} for k := multiplier to (multiplier + 7) do begin if (k = multiplier) then begin y^[k, 1] := miny1; y^[k, 2] := miny2; y^[k, 3] := miny3; end; if (k = multiplier + 1) then begin y^[k, 1] := maxy1; y^[k, 2] := miny2; y^[k, 3] := miny3; end; if (k = multiplier + 2) then begin y^[k, 1] := miny1; y^[k, 2] := miny2; y^[k, 3] := miny3; end; if (k = multiplier + 3) then begin y^[k, 1] := miny1; y^[k, 2] := maxy2; y^[k, 3] := miny3; end; if (k = multiplier + 4) then begin y^[k, 1] := miny1; y^[k, 2] := miny2; y^[k, 3] := miny3; end; if (k = multiplier + 5) then begin y^[k, 1] := miny1; y^[k, 2] := miny2; y^[k, 3] := maxy3; end; if (k = multiplier + 6) then begin y^[k, 1] := miny1; y^[k, 2] := maxy2; y^[k, 3] := maxy3; end; if (k = multiplier + 7) then begin y^[k, 1] := miny1; y^[k, 2] := maxy2; y^[k, 3] := miny3; end; end; for k := (multiplier + 8) to (multiplier + 17) do begin {Y axis value labels} if (k = multiplier + 8) then begin y^[k, 1] := miny1 + ((maxy1 - miny1) * 0.5 * labset); y^[k, 2] := miny2 - ((maxy2 - miny2) * 6 * labset); y^[k, 3] := miny3; end; if (k = multiplier + 9) then begin y^[k, 1] := maxy1 - ((maxy1 - miny1) * labset); y^[k, 2] := miny2 - ((maxy2 - miny2) * 5 * labset); y^[k, 3] := miny3; end; {X axis value labels} if (k = multiplier + 10) then begin y^[k, 1] := miny1 + ((maxy1 - miny1) * 0.5 * labset); y^[k, 2] := miny2 + ((maxy2 - miny2) * labset); y^[k, 3] := miny3; end; if (k = multiplier + 11) then begin y^[k, 1] := miny1 - ((maxy1 - miny1) * 1.5 * labset); y^[k, 2] := maxy2 - ((maxy2 - miny2) * 2 * labset); y^[k, 3] := miny3; end; {Z axis value labels} if (k = multiplier + 12) then begin y^[k, 1] := miny1; y^[k, 2] := miny2 - ((maxy2 - miny2) * 7 * labset); y^[k, 3] := miny3 + ((maxy3 - miny3) * 3 * labset); end; if (k = multiplier + 13) then begin y^[k, 1] := miny1; y^[k, 2] := miny2 - ((maxy2 - miny2) * 6.5 * labset); y^[k, 3] := maxy3; end; {The X-axis label} if (k = multiplier + 14) then begin y^[k, 1] := miny1 - ((maxy1 - miny1) * 3 * labset); y^[k, 2] := miny2 + ((maxy2 - miny2) * 0.5); y^[k, 3] := miny3; end; {The Z-axis label} if (k = multiplier + 15) then begin y^[k, 1] := miny1; y^[k, 2] := miny2 - ((maxy2 - miny2) * 0.6); y^[k, 3] := miny3 + ((maxy3 - miny3) * 0.7); end; {The Y-axis label} if (k = multiplier + 16) then begin y^[k, 1] := miny1 + ((maxy1 - miny1) * 4 * labset); y^[k, 2] := miny2 - ((maxy2 - miny2) * 3 * labset); y^[k, 3] := miny3; end; {The TITLE} if (k = multiplier + 17) then begin y^[k, 1] := maxy1 + 6 * labset; y^[k, 2] := miny2 - ((maxy2 - miny2) * 5 * labset); y^[k, 3] := miny3; end; end; scale1 := (maxy1 - miny1); scale2 := (maxy2 - miny2); scale3 := (maxy3 - miny3); phi := angle * (pi / 180); for k := anza to kwisha do begin yy^[k, 1] := y^[k, 1] / scale1; yy^[k, 2] := y^[k, 2] / scale2; yy^[k, 3] := y^[k, 3] / scale3; for j := 1 to 2 do begin if (j = 1) then newx^[k, j] := yy^[k, j] + (yy^[k, 3] * perspect * cos(phi)); if (j = 2) then newx^[k, j] := yy^[k, j] + (yy^[k, 3] * perspect * sin(phi)); if ((k = anza) and (j = 2)) then begin minx1 := newx^[anza, 1]; maxx1 := newx^[anza, 1]; minx2 := newx^[anza, 2]; maxx2 := newx^[anza, 2]; end; end; if ((k > anza) and (k < kwisha)) then begin if (newx^[k, 1] < minx1) then minx1 := newx^[k, 1]; if (newx^[k, 1] > maxx1) then maxx1 := newx^[k, 1]; if (newx^[k, 2] < minx2) then minx2 := newx^[k, 2]; if (newx^[k, 2] > maxx2) then maxx2 := newx^[k, 2]; end; end; {moveto(70, 20);} {WriteDraw('xmin=', miny2 : 5 : 3, ' ymin=', miny1 : 5 : 3, ' zmin=', miny3 : 5 : 3);} {moveto(70, 40);} {WriteDraw('xmax=', maxy2 : 5 : 3, ' ymax=', maxy1 : 5 : 3, ' zmax=', maxy3 : 5 : 3);} TextSize(12); PenSize(1, 1); if (psprint = 1) then post1; for k := anza to kwisha do begin transx1 := round(height - (25 + ((newx^[k, 1] - minx1) / (maxx1 - minx1)) * (height - 50))); transx2 := round(25 + ((newx^[k, 2] - minx2) / (maxx2 - minx2)) * (width - 50)); transx3 := (25 + ((newx^[k, 1] - minx1) / (maxx1 - minx1)) * (height - 50)); transx4 := (25 + ((newx^[k, 2] - minx2) / (maxx2 - minx2)) * (width - 50)); diam := 1; if ((y^[k, 1] >= x1dlow) and (y^[k, 1] <= x1dhigh)) then diam := 2; if (k < multiplier) then begin {PaintCircle(transx2, transx1, diam);} if (y^[k, 5] = 1) then begin moveto(transx2, transx1); WriteDraw('.'); if (highlite = 1) then begin if ((y^[k, 1] >= x1dlow) and (y^[k, 1] <= x1dhigh)) then begin TextSize(13); WriteDraw('.'); TextSize(12); end; {PaintCircle(transx2, transx1, diam);} end; end; if (y^[k, 5] = 2) then begin lineto(transx2, transx1); end; if (psprint = 1) then begin if (y^[k, 5] = 1) then begin writeln(ps1, transx4 : 7 : 2, ' ', transx3 : 7 : 2, ' ', 'moveto '); writeln(ps1, '(.) show'); if (highlite = 1) then begin if ((y^[k, 1] >= x1dlow) and (y^[k, 1] <= x1dhigh)) then begin writeln(ps1, '/Helvetica-Bold findfont 25 scalefont setfont'); writeln(ps1, '(.) show'); writeln(ps1, '/Times-Bold findfont 15 scalefont setfont'); end; end; end; if (y^[k, 5] = 2) then begin writeln(ps1, transx4 : 7 : 2, ' ', transx3 : 7 : 2, ' ', 'lineto '); end; end; end; if (k = multiplier) then begin moveto(transx2, transx1); if (psprint = 1) then begin writeln(ps1, transx4 : 7 : 2, ' ', transx3 : 7 : 2, ' ', 'moveto '); writeln(ps1, '/Helvetica-Bold findfont'); writeln(ps1, '15 scalefont'); writeln(ps1, 'setfont'); end; end; if ((k > multiplier) and (k < (multiplier + 8))) then begin lineto(transx2, transx1); if (psprint = 1) then writeln(ps1, transx4 : 7 : 2, ' ', transx3 : 7 : 2, ' ', 'lineto '); end; if (k > (multiplier + 7)) then begin moveto(transx2, transx1); if (k = (multiplier + 8)) then WriteDraw(miny1 : 5 : 3); if (k = (multiplier + 9)) then WriteDraw(maxy1 : 5 : 3); if (k = (multiplier + 10)) then WriteDraw(miny2 : 5 : 3); if (k = (multiplier + 11)) then WriteDraw(maxy2 : 5 : 3); if (k = (multiplier + 12)) then WriteDraw(miny3 : 5 : 3); if (k = (multiplier + 13)) then WriteDraw(maxy3 : 5 : 3); if (psprint = 1) then begin writeln(ps1, transx4 : 7 : 2, ' ', transx3 : 7 : 2, ' ', 'moveto '); if (k = (multiplier + 8)) then writeln(ps1, '(', miny1 : 5 : 3, ') show'); if (k = (multiplier + 9)) then writeln(ps1, '(', maxy1 : 5 : 3, ') show'); {if (k = (multiplier + 10)) then writeln(ps1, '(' , miny2 : 5 : 3, ') show');} {if (k = (multiplier + 11)) then writeln(ps1, '(', maxy2 : 5 : 3, ') show');} if (k = (multiplier + 12)) then writeln(ps1, '(', miny3 : 5 : 3, ') show'); if (k = (multiplier + 13)) then writeln(ps1, '(', maxy3 : 5 : 3, ') show'); if (k = (multiplier + 14)) then begin writeln(ps1, (transx4 - 72) : 7 : 2, ' ', (transx3 - 130) : 7 : 2, ' ', 'moveto '); writeln(ps1, '(X AXIS RANGE=[', miny2 : 5 : 3, ', ', maxy2 : 5 : 3, ']) show '); end; if (k = (multiplier + 15)) then writeln(ps1, '(Z AXIS) show '); if (k = (multiplier + 16)) then begin writeln(ps1, 'gsave'); writeln(ps1, '90 rotate'); writeln(ps1, '(Y AXIS) show'); writeln(ps1, 'grestore'); end; if (k = (multiplier + 17)) then writeln(ps1, '(TITLE) show '); end; end; if (traject = 1) then writeln('x=', y^[k, 2] : 8 : 6, ' y=', y^[k, 1] : 8 : 6, ' z=', y^[k, 3] : 8 : 6, ' count=', y^[k, 4] : 8 : 1); end; if (psprint = 1) then post2; end; procedure newton; var control1, control2, i, v, control3, newtnum, x2dim: integer; continc1, continc2, x1next, x2next, test1, test2, x1newt, x2newt, x1save, x2save: real; begin x2dim := dim * 3; newtnum := dim; acc := 0.005; continc1 := (x1high - x1low) / newtnum; continc2 := (x2high - x2low) / (x2dim); mx[1] := x1low; mx[2] := x2low; x1newt := mx[1]; x2save := x2low; for control2 := 1 to (x2dim + 1) do begin x1newt := x1low; x1save := x1newt; control3 := 0; for control1 := 1 to (newtnum + 1) do begin mx[1] := x1newt; for i := 1 to 9 do begin x1next := mx[1] - (eq1 / par1x1); mx[1] := x1next; end; test1 := abs(eq1); test2 := abs(mx[1] - x1save); {writeln(test1 : 8 : 5);} if ((test1 < acc) and (test2 > acc)) then begin count := count + 1; y^[count, 1] := mx[1]; y^[count, 2] := mx[2]; y^[count, 3] := p[1]; y^[count, 4] := count; y^[count, 5] := connect; if (limits = 1) then begin if (mx[1] < x1low) then y^[count, 1] := x1low; if (mx[1] > x1high) then y^[count, 1] := x1high; end; connect := 1; {writeln(y^[count, 1], ' ', y^[count, 2], ' ', y^[count, 3], ' ', y^[count, 4], ' p2=', p[2]);} end; x1save := mx[1]; x1newt := x1newt + continc1; end; x2save := mx[2]; mx[2] := mx[2] + continc2; {writeln(continc2, ' ', mx[2]);} end; writeln('Count = ', count); end; function rtbis (k1, k2, xacc: real): real; label 99; const jmax = 40; var dx, f, fmid, xmid, rtb: real; j: integer; begin fmid := fx(k2); f := fx(k1); if f * fmid >= 0.0 then begin writeln('Pause in rtbis: root must be bracketed for bisection'); readln; end; if f < 0.0 then begin rtb := k2; dx := k2 - k1; end else begin rtb := k2; dx := k1 - k2; end; for j := 1 to jmax do begin dx := dx * 0.5; xmid := rtb + dx; fmid := fx(xmid); if fmid <= 0.0 then rtb := xmid; if (abs(dx) < xacc) or (fmid = 0.0) then goto 99; end; writeln('Pause in rtbis: too many bisections'); readln; 99: rtbis := rtb; end; procedure bisect; var control1, control2, i, v, control3, newtnum, binum: integer; continc1, continc2, x1next, x2next, test1, test2, x1newt, x2newt, x1save, x2save: real; begin binum := 20; continc1 := (x1high - x1low) / binum; continc2 := (x2high - x2low) / dim; mx[1] := x1low; mx[2] := x2low; x1newt := mx[1]; for control2 := 1 to (dim + 1) do begin x1newt := x1low; control3 := 0; for control1 := 1 to binum do begin mx[1] := x1newt; count := count + 1; y^[count, 1] := mx[1]; y^[count, 2] := mx[2]; y^[count, 3] := p[1]; y^[count, 4] := count; if (limits = 1) then begin if (mx[1] < x1low) then y^[count, 1] := x1low; if (mx[1] > x1high) then y^[count, 1] := x1high; end; {writeln(y^[count, 1], ' ', y^[count, 2], ' ', y^[count, 3], ' ', y^[count, 4], ' p2=', p[2]);} x1newt := x1newt + continc1; end; mx[2] := mx[2] + continc2; {writeln(continc2, ' ', mx[2]);} end; end; procedure answer; var parnum, ii: integer; begin writeln('What model do you want? 1-fragmentation 2-frag w/shift 3-frag w/shift&lim '); write(' 4-Nazis 5-catvoter 6-estimated cat voter '); readln(input, kitu); if (kitu = 1) then nn := 3; write('Do you want one picture or a series? 1-one 2-series '); readln(input, series); write('Do you want to print the graph using a postscript file? 1-yes 2-no '); readln(input, psprint); write('Do you want to view the variable values? 1-yes 2-no '); readln(input, traject); write('Do you want a cross-section? 1-yes 2-no '); readln(input, cross); write('Do you want Newtons method or a bisection method? 1-Newtons 2-bisection '); readln(input, method); if (cross = 2) then begin write('Do you want a 2D or a 3D phase diagram? 0=2D 1=3D '); readln(input, perspect); write('What rotation angle do you want? 1=120 degrees 2-other '); readln(input, rotation); if (rotation = 1) then angle := 120; if (rotation = 2) then begin write(' What specific angle do you want ? '); readln(input, angle); end; end; write('Do you want vertical limits on the plot? 1-yes 2-no '); readln(input, limits); write('What resolution do you want on your axes? '); readln(input, dim); if (kitu = 4) then begin write('What year do you want? 1:1928-30 2:1930-32 '); readln(input, year); write('What is the value of the conditioning variable? '); readln(input, w1); write('How much do you want to expand the floor axes? Any number from 0 to ?? '); readln(input, expand); if (year = 1) then parm1; if (year = 2) then parm2; write('Do you want to highlight the vertical data areas? 1-yes 2-no '); readln(input, highlite); end; if (series = 2) then begin write('For a series of plots, what is your lower value in the range for your second parameter? '); readln(input, lowp2); write('What is your higher value in the range for your second parameter? '); readln(input, highp2); end; if (kitu <> 4) then begin if (kitu < 4) then begin write('What is your low value for variable x1? '); readln(input, x1low); write('What is your high value for variable x1? '); readln(input, x1high); write('What is your low value for variable x2? '); readln(input, x2low); write('What is your high value for variable x2? '); readln(input, x2high); if (cross = 2) then begin write('What is your lower value in the range for your z axis parameter? '); readln(input, lowp1); write('What is your higher value in the range for your z axis parameter? '); readln(input, highp1); end; end; if (kitu = 5) then begin write('How much do you want to expand the floor axes? Any number from 0 to ?? '); readln(input, expand); x1low := -1; x1high := 2; x2low := 0 - expand; x2high := 1 + expand; lowp1 := 0 - expand; highp1 := 1 + expand; end; if (kitu = 6) then begin writeln('Hoiw do you want the model conditioned? 1-none 2-Republican 3-Democratic 4-Neighbors '); write('5-Raes F '); readln(input, condques); write('How much do you want to expand the floor axes? Any number from 0 to ?? '); readln(input, expand); x1low := -1; x1high := 2; x2low := 0 - expand; x2high := 1 + expand; lowp1 := 0 - expand; highp1 := 1 + expand; parm3; lowp2 := p[2]; highp2 := p[2]; end; if (cross = 1) then begin write('What is the value of the z control variable? '); readln(input, lowp1); highp1 := lowp1; perspect := 0; end; if (kitu <> 6) then begin if (series = 1) then begin write('What is the value of your second parameter? '); readln(input, p[2]); lowp2 := p[2]; highp2 := p[2]; end; write('How many other parameters are there in the model? '); readln(input, parnum); for ii := 3 to (parnum + 2) do begin write('What is the value for parameter ', ii, ' ?'); readln(input, p[ii]); end; end; end; end; procedure range; var c1, c2, dimc2, dimc1: integer; begin initnums; if (series = 1) then dimc2 := 1; if (series = 2) then dimc2 := dim; if (cross = 1) then dimc1 := 1; if (cross = 2) then dimc1 := dim; for c2 := dimc2 downto 1 do begin count := 0; shift := lowp2 + ((highp2 - lowp2) * ((c2 - 1) / (dim - 1))); p[2] := shift; ticker := ticker + 1; if (series = 2) then begin writeln('p2=', p[2] : 8 : 4, ' ticker', ticker); end; for c1 := 1 to dimc1 do begin ticker2 := ticker2 + 1; connect := 1; p[1] := lowp1 + ((highp1 - lowp1) * ((c1 - 1) / (dim - 1))); if (method = 1) then newton; if (method = 2) then bisect; end; graph; end; end; begin initialize; showtext; showdrawing; answer; if (psprint = 1) then rewrite(ps1, ps1name); range; if (psprint = 1) then close(ps1); end.
|
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|