API tools faq
paste
Advertisement
Jade39

xyita

Jade39
May 1st, 2014
263
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Delphi 13.33 KB | None | 0 0
raw download clone embed print report
  1. program lab_sm1;
  2.  
  3. {$APPTYPE CONSOLE}
  4.  
  5. uses
  6.   SysUtils,
  7.   Math;
  8.  
  9. type matr=array [1..50,1..50] of real;
  10. type vect=array [1..50] of real;
  11. type Avect=array [1..1010] of vect;
  12. var
  13. a,c,b,a1,c1,b1: array [1..1010] of matr;
  14. zz:array [1..50,1..50] of matr;
  15. y,f,f1,y1,betta,betta1,zzz1,zzz2:Avect;
  16. i,j,i1,j1,k,n1,m1,n,m:integer;
  17. obr,matr2,matr3,matr0,obr_1,matr2_1,matr3_1,matr0_1,s1,s2,s3,p,p1,p2:matr;
  18. matr1,matr1_1,U,RR:vect;
  19. alfa,alfa1,S:array [1..1010] of matr;
  20. r: array [1..50] of real;
  21. {-------------------------------------------------------------------------------}
  22. function gauss(a:matr;b:vect;n,m:integer):vect;
  23. var i,j,k,l:integer;
  24. max,c,z,tmp:real;
  25. y3,e:vect;
  26. begin
  27.  
  28.    // ~~~gauss~~~
  29.    for k:=1 to m-1 do begin
  30.        max:=abs(a[k][k]);
  31.        l:=k;
  32.        for j:=k+1 to m do begin
  33.            if abs(a[j][k])>max then begin
  34.               l:=j;
  35.               max:=abs(a[j][k]);
  36.            end;
  37.        end;
  38.        if l<>k then begin
  39.           for j:=k to m do begin
  40.              tmp:=a[l,j];
  41.              a[l,j]:=a[k,j];
  42.              a[k,j]:=tmp;
  43.           end;
  44.           tmp:=b[k];
  45.           b[k]:=b[l];
  46.           b[l]:=tmp;
  47.        end;
  48.  
  49.        for i:=k+1 to m do begin
  50.          c:=a[i,k]/a[k,k];
  51.          b[i]:=b[i]-b[k]*c;
  52.          for j:=k to m do a[i][j]:=a[i][j]-a[k][j]*c;
  53.        end;
  54.    end;
  55.  
  56.    y3[m]:=b[m]/a[m,m];
  57.  
  58.    for k:=m-1 downto 1 do begin
  59.        z:=b[k];
  60.        for i:=k+1 to m do z:=z-a[k][i]*y3[i];
  61.        y3[k]:=z/a[k][k];
  62.    end;
  63.  
  64.    // ~~~gauss~~~
  65.  
  66.  
  67.       gauss:=y3;
  68. end;
  69. {-------------------------------------------------------------------------------}
  70. function obrat(a:matr;n,m:integer):matr;
  71. var
  72. u,l,tmp,obr:matr;
  73. c,sum:real;
  74. i,j,k,f3,t:integer;
  75. e:vect;
  76. x3,y3,b3:array [1..100] of vect;
  77. begin
  78.  f3:=1;
  79.    for i:= f3 to m do
  80.                Begin
  81.                   for j:=f3 to m do
  82.                   begin
  83.                      L[i,j]:=0;
  84.                      U[i,j]:=0;
  85.                   end;
  86.                end;
  87.                for i:=f3 to m do
  88.                Begin
  89.                   for j:=f3 to m do
  90.                   Begin
  91.                      U[f3,i]:=a[f3,i];
  92.                      L[i,f3]:=a[i,f3]/U[f3, f3];
  93.                      sum:=0;
  94.                      for k:=f3 to i do sum:=sum+L[i, k]*U[k, j];
  95.                      U[i,j]:=a[i, j]-sum;
  96.                      if i>j then L[j,i]:=0 else
  97.                      Begin
  98.                         sum := 0;
  99.                         for k := f3 to i do sum := sum + L[j, k] * U[k, i];
  100.                         if U[i, i] <> 0 then L[j, i] :=(a[j, i] - sum)/U[i, i];
  101.                      end;
  102.                   end;
  103.                end;
  104.    for j:=1 to m do b3[1][j]:=0;
  105.    for k:=2 to m do b3[k]:=b3[1];
  106.    for k:=1 to m do b3[k][k]:=1;
  107.  
  108.    for j:=1 to m do y3[j]:=gauss(l,b3[j],n,m);
  109.    for j:=1 to m do x3[j]:=gauss(u,y3[j],n,m);
  110.  
  111.   for j:=1 to m do
  112.   for i:=1 to m do  obr[i][j]:=x3[j][i];
  113.  
  114.    obrat:=obr;
  115. end;
  116. {-------------------------------------------------------------------------------}
  117. // proizvedenie matrits
  118. function multi(a,b:matr;m:integer):matr;
  119. var i,j,k:integer;
  120. tmp:real;
  121. c:matr;
  122. begin
  123. for i:=1 to m do
  124.   for j:=1 to m do begin
  125.      tmp:=0;
  126.      for k:=1 to m do begin
  127.          tmp:=tmp+a[i][k]*b[k][j];
  128.      end;
  129.      c[i][j]:=tmp;
  130.    end;
  131.    multi:=c;
  132. end;
  133.  
  134. {-------------------------------------------------------------------------------}
  135. function Trans(a:matr;n,m:integer):matr;
  136. Var i,j : integer;
  137.     c : matr;
  138. Begin
  139.  //c:=a;
  140.  For i:=0 to n do
  141.      For j:=0 to m do
  142.          a[i,j]:=c[j,i];
  143. End;
  144. {-------------------------------------------------------------------------------}
  145. function MTRAN(X:matr;N,K:integer):matr;
  146. Var
  147.   I,J:integer;
  148.    XTR:matr;
  149. BEGIN
  150.   for I := 1 to N do
  151.   for j := 1 to K do
  152.   XTR[J,I]:=X[I,J];
  153. END;
  154.  
  155. {-------------------------------------------------------------------------------}
  156. // proizvedenie matritsy na stolbets
  157. function pulti(a:matr;b:vect;m:integer):vect;
  158. var i,j,k:integer;
  159. tmp:real;
  160. c:vect;
  161. begin
  162.   for i:=1 to m do begin
  163.      tmp:=0;
  164.      for k:=1 to m do begin
  165.          tmp:=tmp+a[i][k]*b[k];
  166.      end;
  167.      c[i]:=tmp;
  168.    end;
  169.    pulti:=c;
  170. end;
  171. {-------------------------------------------------------------------------------}
  172. // slogenie matrits
  173. function plus(a,b:matr;m:integer):matr;
  174. var i,j,k:integer;
  175. tmp:real;
  176. c:matr;
  177. begin
  178. for i:=1 to m do
  179.   for j:=1 to m do begin
  180.      c[i][j]:=a[i][j]+b[i][j];
  181.   end;
  182.   plus:=c;
  183. end;
  184. {-------------------------------------------------------------------------------}
  185. function minus(a,b:matr;m:integer):matr;
  186. var i,j,k:integer;
  187. tmp:real;
  188. c:matr;
  189. begin
  190. for i:=1 to m do
  191.   for j:=1 to m do begin
  192.      c[i][j]:=a[i][j]-b[i][j];
  193.   end;
  194.   minus:=c;
  195. end;
  196. {-------------------------------------------------------------------------------}
  197. function mult(a,b:matr;n,m:integer):matr;
  198. var
  199. i,j,k : Integer;
  200.         s,Res:matr;
  201. begin
  202. for i:=1 to n do begin
  203. for j:=1 to m*m do begin
  204. s[i,j]:=0;end;end;
  205.  
  206.         for i := 1 to n do
  207.         for j := 1 to m*m do
  208.              begin
  209.  
  210.                      for k := 1 to m*m do
  211.                           s[i,j]:=s[i,j]+a[i,k]*b[k,j];
  212.                      Res[i,j]:=s[i,j];
  213.              end;
  214.         mult:=Res;
  215. end;
  216.  
  217. {-------------------------------------------------------------------------------}
  218. function A23(n,m:integer):matr;
  219. var
  220. i,j,k,z,l:integer;
  221.  a,b:matr;
  222.  begin
  223.  z:=1;
  224.  l:=0;
  225.  for i:=1 to m*m do begin
  226.  for j:=1 to n do
  227.  
  228.      if (i=z+m*l )and (j=z+l) then begin
  229.       a[i,j]:=-1; //z:=z+1;
  230.       l:=l+1;
  231.       end
  232.      else a[i,j]:=0;
  233.   end;
  234.     {for j:=1 to n do  begin
  235.     for i:=1 to m*m do  begin
  236.       a[i,j]:=0;end;end;
  237.  
  238.         for j:=1 to m*m do
  239.         for i:=1 to n do
  240.          a[j,i]:=b[i,j];  }
  241.  
  242.   {for i:=1 to m*m do begin
  243.     for j:=1 to n do begin
  244.     write(a[i,j]:6:1,' ');end;writeln;end;}
  245.   A23:=a;
  246. end;
  247. {-------------------------------------------------------------------------------}
  248. function A23T(n,m:integer):matr;
  249. var
  250. i,j,k,z,l:integer;
  251.  a,b:matr;
  252.  begin
  253.  z:=1;
  254.  l:=0;
  255.  for j:=1 to m*m do begin
  256.  for i:=1 to n do
  257.  
  258.      if (i=z+l )and (j=z+m*l) then begin
  259.       a[i,j]:=-1; //z:=z+1;
  260.       l:=l+1;
  261.       end
  262.      else a[i,j]:=0;
  263.   end;
  264.   {for i:=1 to n do begin
  265.     for j:=1 to m*m do begin
  266.     write(a[i,j]:6:1,' ');end;writeln;end; }
  267.   A23T:=a;
  268. end;
  269. {-------------------------------------------------------------------------------}
  270.  function A13T(n,m:integer):matr;
  271.  var
  272.  i,j,k,z:integer;
  273.  a,b:matr;
  274.  begin
  275.  z:=1;
  276.  for j:=1 to n do begin
  277.  for i:=1 to m*m do
  278.  
  279.      if (i=z*n)and (j=z) then begin
  280.       a[i,j]:=-1; z:=z+1;end
  281.      else a[i,j]:=0;
  282.   end;
  283.     for j:=1 to n do
  284.     for i:=1 to m*m do
  285.   b[j,i]:=a[i,j];
  286.     A13T:=b;
  287.    {
  288.     for i:=1 to n do begin
  289.     for j:=1 to n*n do begin
  290.     write(b[i,j]:6:1,' ');end;writeln;end; }
  291.  end;
  292. {-------------------------------------------------------------------------------}
  293. function A13(n,m:integer):matr;
  294.  var
  295.  i,j,k,z:integer;
  296.  a,b:matr;
  297.  begin
  298.  z:=1;
  299.  for j:=1 to n do begin
  300.  for i:=1 to m*m do begin
  301.        a[i,j]:=0;
  302.      if (i=z*m)and (j=z) then begin
  303.       a[i,j]:=-1; z:=z+1;end;end;
  304.      //else
  305.   end;
  306.     A13:=a;
  307.    { for j:=1 to n do
  308.     for i:=1 to n*n do
  309.   b[j,i]:=a[i,j];}
  310.   {
  311.     for i:=1 to n*n do begin
  312.     for j:=1 to m do begin
  313.     write(a[i,j]:6:1,' ');end;writeln;end; }
  314.  end;
  315. {-------------------------------------------------------------------------------}
  316. function Ann(m:integer):matr;
  317. var
  318.  i,j,k:integer;
  319.  q,c:matr;
  320. begin
  321.  
  322.    for i:=1 to m*m do begin
  323.    for j:=1 to m*m do begin
  324.       if i=j then q[i,j]:=4
  325.        else if (i+m=j) or (i=j+m) or (i+1=j) or (i=j+1) then q[i,j]:=-1
  326.       else q[i,j]:=0;
  327.     end;
  328.     end;
  329.        for i:=1 to m*m do begin
  330.        for j:=1 to m*m do begin
  331.          for k:=1 to m-1 do begin
  332.           if ((i=m*k+1) and (j=m*k)) or ((i=m*k) and (j=m*k+1))  then q[i,j]:=0;
  333.           end;end;end;
  334.  
  335.           c:=obrat(q,m*m,m*m);
  336.  
  337.      { for i:=1 to m*m do  begin
  338.       for j:=1 to m*m do  begin
  339.         write(q[i,j]:4:1,' ');
  340.        end; writeln; end;}
  341.  
  342.        Ann:=c;
  343.  
  344. end;
  345. {-------------------------------------------------------------------------------}
  346. function A33(a,b:integer):matr;
  347. var
  348. i,j:integer;
  349. q:matr;
  350. begin
  351. for i:=1 to a do  begin
  352. for j:=1 to b do  begin
  353.        if i=j then q[i,j]:=4
  354.        else if (i+1=j) or (i=j+1) then q[i,j]:=-1
  355.        else   q[i,j]:=0;
  356.    end;end;
  357.   {  for i:=1 to a do  begin
  358.      for j:=1 to b do  begin
  359.      write(q[i,j]:6:1,' ');
  360.      end; writeln; end; }
  361.  
  362.      A33:=q;
  363. end;
  364. {-------------------------------------------------------------------------------}
  365. //slozhenie stolbtsov
  366. function plus1(a,b:vect;m:integer):vect;
  367. var
  368. i:integer;
  369. c:vect;
  370. begin
  371.   for i:=1 to m do  c[i]:=a[i]+b[i];
  372.   plus1:=c;
  373. end;
  374. {-------------------------------------------------------------------------------}
  375. procedure matrprog(n,m,n1,m1:integer;f,f1:Avect);
  376. //procedure matrprog(n,m,n1,m1:integer);
  377. var i,j,k,i1,j1,k1:integer;
  378. begin
  379. for i:=1 to n do
  380. for j:=1 to m do f[i][j]:=16;
  381. for k:=1 to n do
  382. for i:=1 to m do  begin
  383.    for j:=1 to m do begin
  384.        if i=j then begin
  385.           a[k][i,i]:=-1;
  386.           b[k][i,i]:=-1;
  387.        end;
  388.    end;
  389. end;
  390.  
  391. for i1:=1 to n1 do
  392. for j1:=1 to m1 do f1[i1][j1]:=16;
  393. for k1:=1 to n1 do
  394. for i1:=1 to m1 do  begin
  395.    for j1:=1 to m1 do begin
  396.        if i1=j1 then begin
  397.           a1[k1][i1,i1]:=-1;
  398.           b1[k1][i1,i1]:=-1;
  399.        end;
  400.    end;
  401. end;
  402.  
  403. for k:=1 to n do
  404. for i:=1 to m do
  405.    for j:=1 to m do begin
  406.        if i=j then c[k][i,j]:=4;
  407.        if (i-j=1) or (i-j=-1) then c[k][i,j]:=-1
  408.    end;
  409.  
  410.  
  411.  
  412. for k1:=1 to n1 do
  413. for i1:=1 to m1 do
  414.    for j1:=1 to m1 do begin
  415.        if i1=j1 then c1[k1][i1,j1]:=4;
  416.        if (i1-j1=1) or (i1-j1=-1) then c1[k1][i1,j1]:=-1
  417.  
  418.    end;
  419.  
  420. //----------------- 1 oblast'  -----------------------------
  421.  
  422. alfa[1]:=multi(obrat(c[1],n,m),b[1],m);
  423.  
  424. for i:=1 to m do
  425. for j:=1 to m do alfa[1][i][j]:=(-1)*alfa[1][i][j];
  426. betta[1]:=pulti(obrat(c[1],n,m),f[1],m);
  427.  
  428. for k:=2 to n do begin
  429.     matr2:=multi(a[k],alfa[k-1],m);
  430.     matr3:=plus(c[k],matr2,m);
  431.     obr:=obrat(matr3,n,m);
  432.     for i:=1 to m do
  433.       for j:=1 to m do obr[i][j]:=(-1)*obr[i][j];
  434.     alfa[k]:=multi(obr,b[k],m);
  435.     for i:=1 to m do
  436.       for j:=1 to m do obr[i][j]:=(-1)*obr[i][j];
  437.     matr1:=pulti(a[k],betta[k-1],m);
  438.     for i:=1 to m do matr1[i]:=(-1)*matr1[i];
  439.     betta[k]:=pulti(obr,plus1(f[k],matr1,m),m);
  440. end;
  441.  
  442.  //-------------------2 oblast' -----------------------
  443.  alfa1[1]:=multi(obrat(c1[1],n1,m1),b1[1],m1);
  444. for i1:=1 to m1 do
  445. for j1:=1 to m1 do alfa1[1][i1][j1]:=(-1)*alfa1[1][i1][j1];
  446. betta1[1]:=pulti(obrat(c1[1],n1,m1),f1[1],m1);
  447. for k1:=2 to n1 do begin
  448.     matr2_1:=multi(a1[k1],alfa1[k1-1],m1);
  449.     matr3_1:=plus(c1[k1],matr2_1,m1);
  450.     obr_1:=obrat(matr3_1,n1,m1);
  451.     for i1:=1 to m1 do
  452.       for j1:=1 to m1 do obr_1[i1][j1]:=(-1)*obr_1[i1][j1];
  453.     alfa1[k1]:=multi(obr_1,b1[k1],m1);
  454.     for i1:=1 to m1 do
  455.       for j1:=1 to m1 do obr_1[i1][j1]:=(-1)*obr_1[i1][j1];
  456.     matr1_1:=pulti(a1[k1],betta1[k1-1],m1);
  457.     for i1:=1 to m1 do matr1_1[i1]:=(-1)*matr1_1[i1];
  458.     betta1[k1]:=pulti(obr_1,plus1(f1[k1],matr1_1,m1),m1);
  459. end;
  460.  
  461.  
  462. y[n]:=betta[n];
  463. for i:=n-1 downto 1 do begin
  464.    y[i]:=pulti(alfa[i],y[i+1],m);
  465.    y[i]:=plus1(y[i],betta[i],m);
  466. end;
  467.    y1[n1]:=betta1[n1];
  468. for i1:=n1-1 downto 1 do begin
  469.    y1[i1]:=pulti(alfa1[i1],y1[i1+1],m1);
  470.    y1[i1]:=plus1(y1[i1],betta1[i1],m1);
  471. end;
  472.    writeln('-------------Reshenie 1 oblasti------------'); writeln;
  473.   for i:=1 to n do  begin
  474.     for j:=1 to m do write(y[i][j]:6:6,' ');
  475.     writeln;
  476.   end;  writeln;
  477.      writeln('-------------Reshenie 2 oblasti------------');
  478.     writeln;
  479.    for i1:=1 to n1 do  begin
  480.     for j1:=1 to m1 do write(y1[i1][j1]:6:6,' ');
  481.     writeln;
  482.   end;
  483.      writeln('-------------nev9zka na linii scepleni9------------');
  484.       for i:=1 to n1 do  begin
  485.       RR[i]:=y1[i][1]+y[n-n1+i][m]+16;
  486.        writeln(RR[i]:6:6,' ');
  487.        end; writeln;
  488.  
  489.  
  490. end;
  491.  
  492.  
  493. begin
  494. assign(output,'output.txt');
  495. rewrite(output);
  496. n:=7;m:=7;
  497. n1:=3;m1:=3;
  498.   for i:=1 to n do
  499.    for j:=1 to m do
  500.      zzz1[i][j]:=16;
  501.         for i1:=1 to n1 do
  502.          for j1:=1 to m1 do
  503.           zzz2[i1][j1]:=16;
  504.  
  505. matrprog(n,m,n1,m1,zzz1,zzz2);
  506. //matrprog(n,m,n1,m1);
  507.  
  508.  
  509.        writeln('-------------rezyltat A13T*A11^(-1)*A13------------');
  510.        s1:=mult(mult(A13T(n1,m1),Ann(m1),n1,m1),A13(n1,m1),n1,m1);
  511.        for i:=1 to n1 do begin
  512.        for j:=1 to m1 do begin
  513.        write(s1[i,j]:6:6,' ');end;writeln;end;;writeln;
  514.  
  515.  
  516.                writeln('-------------rezyltat A23T*A22^(-1)*A23------------');
  517.                s2:=mult(mult(A23T(n1,m),Ann(m),n1,m),A23(n1,m),n1,m);
  518.                for i:=1 to n1 do begin
  519.                for j:=1 to m1 do begin
  520.                write(s2[i,j]:6:6,' ');end;writeln;end; writeln;
  521.                   writeln('-------------rezyltat S=A33-A13T*A11^(-1)*A13-A23T*A22^(-1)*A23------------');
  522.                   s3:=minus(A33(n1,m1),plus(s1,s2,m1),m1);
  523.                   for i:=1 to n1 do begin
  524.                   for j:=1 to m1 do begin
  525.                   write(s3[i,j]:6:6,' ');end;writeln;end; writeln;
  526.                     writeln('-------------U reshenie na linii scepleni9------------');
  527.                     U:=gauss(s3,RR,n1,m1);
  528.                     for i:=1 to n1 do begin
  529.                     write(U[i]:6:6,' ');writeln;end;    
  530.  
  531.  
  532.  
  533. end.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!