home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 09 / bonus / widersta.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1989-05-02  |  16.3 KB  |  650 lines
  1. {***********************************************************************
  2.    Programm Widerstands-Service
  3.    (c) 5/89 by Kurt Winolf 2280 Westerland
  4.    Widerstandsbereich 1 Ohm - 100 MOhm.
  5.  **********************************************************************}
  6. Program widerstand;
  7. Type
  8.    st = string[76];
  9.    str1= string[8];
  10.    str2= string[4];
  11.    Farbtype = Array[0..16] of str1;
  12.    Farbnum  = Array[0..16] of Byte;
  13.    JJ       = Array[1..193] of REAL;
  14.    ee       = Array[1..25] of REAL;
  15.    tt       = Array[1..7] of REAL;
  16.    bb       = Array[1..7] of str2;
  17.    cc       = Array[1..7] of str1;
  18.  
  19.  
  20. const
  21.    Farbring : Farbtype  = (
  22.                'schwarz','braun  ','rot    ','orange ',
  23.                'gelb   ','grün   ','blau   ','violett',
  24.                'grau   ','weiß   ','silber ','gold   ',
  25.                'rot    ','ohne   ','braun  ','rot    ',
  26.                'grün   ');
  27.  
  28.    Farbzahl : Farbnum = (0, 6, 4, 12, 14, 2, 1, 5, 8,
  29.                          15, 15, 14, 4, 7, 6, 4, 2 );
  30.  
  31. e192:JJ =(1.00,1.01,1.02,1.04,1.05,1.06,1.07,1.09,1.10,1.11,
  32.          1.13,1.14,1.15,1.17,1.18,1.20,1.21,1.23,1.24,1.26,
  33.          1.27,1.29,1.30,1.32,1.33,1.35,1.37,1.38,1.40,1.42,
  34.          1.43,1.45,1.47,1.49,1.50,1.52,1.54,1.56,1.58,1.60,
  35.          1.62,1.64,1.65,1.67,1.69,1.72,1.74,1.76,1.78,1.80,
  36.          1.82,1.84,1.87,1.89,1.91,1.93,1.96,1.98,2.00,2.03,
  37.          2.05,2.08,2.10,2.13,2.15,2.18,2.21,2.23,2.26,2.29,
  38.          2.32,2.34,2.37,2.40,2.43,2.46,2.49,2.52,2.55,2.50,
  39.          2.61,2.64,2.67,2.71,2.74,2.77,2.80,2.84,2.87,2.91,
  40.          2.94,2.98,3.01,3.05,3.09,3.12,3.16,3.20,3.24,3.28,
  41.          3.32,3.36,3.40,3.44,3.48,3.52,3.57,3.61,3.65,3.70,
  42.          3.74,3.79,3.83,3.88,3.92,3.97,4.02,4.07,4.12,4.17,
  43.          4.22,4.27,4.32,4.37,4.42,4.48,4.53,4.59,4.64,4.70,
  44.          4.75,4.81,4.87,4.93,4.99,5.05,5.11,5.17,5.23,5.30,
  45.          5.36,5.42,5.49,5.56,5.62,5.69,5.76,5.83,5.90,5.97,
  46.          6.04,6.12,6.19,6.26,6.34,6.42,6.49,6.57,6.65,6.73,
  47.          6.81,6.90,6.98,7.06,7.15,7.23,7.32,7.41,7.50,7.59,
  48.          7.68,7.77,7.87,7.96,8.06,8.16,8.25,8.35,8.45,8.56,
  49.          8.66,8.76,8.87,8.98,9.09,9.20,9.31,9.42,9.53,9.65,
  50.          9.76,9.88,10.00);
  51.  
  52.   e24:ee=( 1.0, 1.1, 1.2, 1.3, 1.5, 1.6, 1.8, 2.0, 2.2, 2.4,
  53.            2.7, 3.0, 3.3, 3.6, 3.9, 4.3, 4.7, 5.1, 5.6, 6.2,
  54.            6.8, 7.5, 8.2, 9.1, 10.0 );
  55.  
  56.  toler:tt=( 40.0, 20.0, 10.0, 5.0, 2.0, 1.0, 0.5 );
  57.  
  58.  bezeichnung : bb = ('E3','E6','E12','E24','E48','E96','E192');
  59.  
  60.  bezeichnung1: cc = ('E3   = 1','E6   = 2','E12  = 3',
  61.                      'E24  = 4','E48  = 5','E96  = 6',
  62.                      'E192 = 7' );
  63.  
  64.  
  65.  
  66. VAR
  67.    auswahl : Char;
  68.    a, b, c, d, tol, dummy : Integer;
  69.    tol1 : String[10];
  70.  
  71. procedure Fensterrahmen(X1,Y1,X2,Y2,HFarbe,FFarbe,HFarbe1,
  72.                     FFarbe1 : Integer; ueberschrift : st);
  73. { zeichnet ein Fenster mit Rahmen. HFarbe & FFarbe ind die
  74.   Rahmenfarben. HFarbe1 & FFarbe1 ind die Fensterfarben.
  75.   Im Rahmen wird in der Mitte die Überschrift ausgageben.}
  76. const
  77.   EckeobenLinks   = #201;
  78.   LineHor         = #205;
  79.   EckeobenRechts  = #187;
  80.   LineVert        = #186;
  81.   EckeuntenLinks  = #200;
  82.   EckeuntenRechts = #188;
  83. var
  84.   I,x,y : integer;
  85.  
  86. begin
  87.   x:= x1+((x2-x1) DIV 2)-((length(ueberschrift) div 2))-1;
  88.   y:= y1-1;
  89.   TextBackground(HFarbe);
  90.   TextColor(FFarbe);
  91.   Window(X1-1,Y1-1,X2+1,Y2+1);
  92.   ClrScr;
  93.   Window(1,1,80,25);
  94.   GotoXY(X1-1,Y1-1);
  95.   Write(EckeobenLinks);
  96.   for I := X1 to X2 do Write(LineHor);
  97.   Write(EckeobenRechts);
  98.   for I := Y1 to Y2 do begin
  99.     GotoXY(X1-1,I); Write(LineVert);
  100.     GotoXY(X2+1,I); Write(LineVert);
  101.   end;
  102.   GotoXY(X1-1,Y2+1);
  103.   Write(EckeuntenLinks);
  104.   for I := X1 to X2 do Write(LineHor);
  105.   Write(EckeuntenRechts);
  106.   GotoXY(x,y);
  107.   writeln(ueberschrift);
  108.   TextBackground(HFarbe1);
  109.   TextColor(FFarbe1);
  110.   Window(X1,Y1,X2,Y2);
  111.   ClrScr;
  112. end;
  113.  
  114. procedure widerstand;
  115. { Zeichnet den Widerstand im Textmodus, um unabhänig
  116.   von einer Grafikkarte zu sein.                    }
  117. const
  118.   EckeobenLinks   = #218;
  119.   LineHor         = #196;
  120.   EckeobenRechts  = #191;
  121.   LineVert        = #179;
  122.   EckeuntenLinks  = #192;
  123.   EckeuntenRechts = #217;
  124. var
  125.   I : integer;
  126.  
  127. begin
  128.   TextBackground(7);
  129.   TextColor(0);
  130.   Window(6,3,70,9);
  131.   ClrScr;
  132.   GotoXY(1,1);
  133.   Write(EckeobenLinks);
  134.   for I := 2 to 63 do Write(LineHor);
  135.   Write(EckeobenRechts);
  136.   for I := 2 to 7 do begin
  137.     GotoXY(1,I); Write(LineVert);
  138.     GotoXY(64,I); Write(LineVert);
  139.   end;
  140.   GotoXY(1,7);
  141.   Write(EckeuntenLinks);
  142.   for I := 2 to 63 do Write(LineHor);
  143.   Write(EckeuntenRechts);
  144.   Window(2,2,78,10);
  145.   GotoXY(2,5); WRITE('───┤');
  146.   GotoXY(68,5); WRITE('├───');
  147. end;
  148.  
  149. Procedure Zeichnering(farbe, x : Integer);
  150. { Zeichnet die Farbringe des Widerstandes.
  151.   mit Farbkarte sind die Ringe farbig.
  152.   Die Farbe wird als Text unter dem Ring ausgegeben }
  153. VAR I :  integer;
  154. Begin
  155.          Textbackground(7);
  156.          Window(x+9,3,x+18,12);
  157.          GotoXY(1,1); Write(#194);
  158.          GotoXY(9,1); Write(#194);
  159.          for I := 2 to 6 do begin
  160.          GotoXY(1,I); Write(#179);
  161.          GotoXY(9,I); Write(#179); End;
  162.          GotoXY(1,7); Write(#193);
  163.          GotoXY(9,7); Write(#193);
  164.          GotoXY(3,8);
  165.          Write(farbring[farbe]);
  166.          TextColor(farbzahl[farbe]);
  167.          Window(x+10,4,x+16,9);
  168.          GotoXY(1,1);
  169.          for I :=1 to 5 Do
  170.             WriteLn('██████');
  171.          GotoXY(1,1);
  172.          TextColor(0);
  173.          Textbackground(7);
  174.          window(2,2,78,10);
  175. end;
  176.  
  177. procedure ring(nr, farbe : integer);
  178. { legt fest, welcher Ring gezeichnet wird. }
  179. Var i : Integer;
  180. begin
  181.   Window(10,4,65,8);
  182.   case nr of
  183.     1 : Zeichnering(farbe, 0);
  184.     2 : Zeichnering(farbe, 9);
  185.     3 : Zeichnering(farbe, 18);
  186.     4 : Zeichnering(farbe, 27);
  187.     5 : Zeichnering(farbe, 45);
  188.   end;
  189. end;
  190.  
  191. Function Eingabe1:Char;
  192. { Auswahl für Menü }
  193. VAR ch : Char;
  194. BEGIN
  195.   Write('Ihre Auswahl bitte ?');
  196.   REPEAT
  197.     Read(kbd,ch);
  198.     IF ch IN ['1'..'6'] Then
  199.     Eingabe1:=ch;
  200.   Until ch IN ['1'..'6'];
  201. End;
  202.  
  203. Function Eingabe2:Char;
  204. { Auswahl für Farben }
  205. VAR ch : Char;
  206. BEGIN
  207.   Write('Ihre Auswahl bitte ?');
  208.   REPEAT
  209.     Read(kbd,ch);
  210.     IF ch IN ['0'..'9'] Then
  211.     Eingabe2:=ch;
  212.   Until ch IN ['0'..'9'];
  213. End;
  214.  
  215. Function Eingabe3:Char;
  216. { Auswahl für Toleranzen Kohle}
  217. VAR ch : Char;
  218. BEGIN
  219.   Write('Ihre Auswahl bitte ?');
  220.   REPEAT
  221.     Read(kbd,ch);
  222.     IF ch IN ['0'..'3'] Then
  223.     Eingabe3:=ch;
  224.   Until ch IN ['0'..'3'];
  225. End;
  226.  
  227. Function Eingabe4:Char;
  228. { Auswahl für Toleranzen Metall }
  229. VAR ch : Char;
  230. BEGIN
  231.   Write('Ihre Auswahl bitte ?');
  232.   REPEAT
  233.     Read(kbd,ch);
  234.     IF ch IN ['0'..'2'] Then
  235.     Eingabe4:=ch;
  236.   Until ch IN ['0'..'2'];
  237. End;
  238.  
  239. Function Eingabe5:Char;
  240. { Auswahl für Baureihe Normwert }
  241. VAR ch : Char;
  242. BEGIN
  243.   Write('Ihre Auswahl bitte ?');
  244.   REPEAT
  245.     Read(kbd,ch);
  246.     IF ch IN ['0'..'7'] Then
  247.     Eingabe5:=ch;
  248.   Until ch IN ['0'..'7'];
  249. End;
  250.  
  251. Procedure MenueEingabe;
  252. BEGIN
  253.   Window(24,10,56,22);
  254.   WriteLn;
  255.   WriteLn('  für Kohleschichtwiderstand');
  256.   WriteLn('1 = Farbcode -> Widerstandswert');
  257.   WriteLn('2 = Widerstandswert -> Farbcode');
  258.   WriteLn;
  259.   WriteLn('  für Metallschichtwiderstand');
  260.   WriteLn('3 = Farbcode -> Widerstandswert');
  261.   WriteLn('4 = Widerstandswert -> Farbcode');
  262.   WriteLn;
  263.   WriteLn('5 = Normwerte Servic');
  264.   WriteLn;
  265.   WriteLn('6 = Programm beenden');
  266.   WriteLn;
  267.   auswahl:=eingabe1;
  268. End;
  269.  
  270. Procedure MenueEingabe1;
  271. { Eingabemenü für Normwert }
  272. VAR I : Integer;
  273. BEGIN
  274.   Window(18,8,60,22);
  275.   ClrScr;
  276.   For I:= 1 to 7 DO
  277.     WriteLn(bezeichnung1[I]);
  278.   WriteLn;
  279.   WriteLn('wählen Sie die Normreihe');
  280.   auswahl:=eingabe5;
  281. End;
  282.  
  283. Procedure Eingabe_Farbringe(Metall:Boolean);
  284. { Menü für Farbringe }
  285. VAR
  286.    I : Integer;
  287. BEGIN
  288.   Fensterrahmen(20,5,60,20,3,0,7,0,
  289.      'Farbcode -> Widerstandswert');
  290.   Window(24,6,56,19);
  291.   WriteLn;
  292.   WriteLn('1. Farbring !!');
  293.   WriteLn;
  294.   for I:=0 to 9 Do
  295.     WriteLn(farbring[I]:8,' = ',I);
  296.   VAL(eingabe2,a,dummy);
  297.   clrScr;
  298.   WriteLn('2. Farbring !!');
  299.   WriteLn;
  300.   for I:=0 to 9 Do
  301.     WriteLn(farbring[I]:8,' = ',I);
  302.   VAL(eingabe2,b,dummy);
  303.   clrScr;
  304.   WriteLn('3. Farbring !!');
  305.   WriteLn;
  306.   for I:=0 to 9 Do
  307.     WriteLn(farbring[I]:8,' = ',I);
  308.   VAL(eingabe2,c,dummy);
  309.   clrScr;
  310.   IF Metall Then BEGIN
  311.     WriteLn('4. Farbring !!');
  312.     WriteLn;
  313.     for I:=0 to 9 Do
  314.     WriteLn(farbring[I]:8,' = ',I);
  315.     VAL(eingabe2,d,dummy);
  316.     clrScr;
  317.   End;
  318.   IF NOT Metall Then  BEGIN
  319.      WriteLn(' Toleranzring');
  320.      for I:=0 to 3 Do
  321.        WriteLn(farbring[I+10]:8,' = ',I);
  322.       VAL(eingabe3,Tol,dummy);
  323.      clrScr;
  324.   End
  325.   Else BEGIN
  326.      WriteLn(' Toleranzring');
  327.      for I:=0 to 2 Do
  328.        WriteLn(farbring[I+14]:8,' = ',I);
  329.       VAL(eingabe4,Tol,dummy);
  330.      clrScr;
  331.   End;
  332.   Window(1,1,80,25);
  333.   clrScr;
  334.   Fensterrahmen(2,2,78,10,1,2,7,0,'╡ Widerstand ╞');
  335.   widerstand;
  336.   ring(1,a);
  337.   ring(2,b);
  338.   ring(3,c);
  339.   IF Metall Then ring(4,d);
  340.   IF Metall Then ring(5,tol+14)
  341.   Else ring(5,tol+10);
  342. End;
  343.  
  344. Procedure taste;
  345. { wartet auf Tastendruck }
  346. VAR
  347.   ch : Char;
  348. BEGIN
  349.   REPEAT
  350.     Read(kbd,ch);
  351.   Until ch <>'';
  352. End;
  353.  
  354. Procedure berechne_wert_kohle1;
  355. { wandelt die Farbringeingabe in
  356.   Widerstandswert um             }
  357. VAR
  358.    I : Integer;
  359.    aa, bb, cc : String[10];
  360.    wert : Real;
  361. BEGIN
  362.   cc := '';
  363.   Fensterrahmen(2,14,78,22,1,2,7,0,
  364.   '╡ Wert des Kohleschichtwiderstandes ╞');
  365.   Window(20,16,70,21);
  366.   Str(a,aa); Str(b,bb);
  367.   for i:=0 to c-1 do
  368.     cc:= Concat(cc,'0');
  369.   cc:= Concat(aa,bb,cc);
  370.   VAL(cc,wert,dummy);
  371.   WriteLn;
  372.   Write(wert:10:1,' Ohm mit ');
  373.   IF tol = 0 Then tol1 := '+- 10%'
  374.   Else IF tol = 1 Then tol1 := '+- 5%'
  375.   Else IF tol = 2 Then tol1 := '+- 2%'
  376.   Else tol1 := '+- 20%';
  377.   WriteLn(tol1,' Tolleranz');
  378.   WriteLn('oder');
  379.   If wert > 1E6 Then BEGIN
  380.      wert := wert / 1E6;
  381.      WriteLn(wert:10:1,' MOhm mit ',tol1,' Tolleranz');
  382.   End
  383.   Else
  384.   If wert > 1E3 Then BEGIN
  385.      wert := wert / 1E3;
  386.      WriteLn(wert:10:1,' KOhm mit ',tol1,' Tolleranz');
  387.   End;
  388.   WriteLn;
  389.   WriteLn('weiter Taste drücken !!');
  390.   taste;
  391. End;
  392.  
  393. Procedure berechne_wert_Metall1;
  394. { wandelt die Farbringeingabe in
  395.   Widerstandswert um             }
  396. VAR
  397.    I : Integer;
  398.    aa, bb, cc, dd : String[10];
  399.    wert : Real;
  400. BEGIN
  401.   dd := '';
  402.   Fensterrahmen(2,14,78,22,1,2,7,0,
  403.   '╡ Wert des Metallschichtwiderstandes ╞');
  404.   Window(20,16,70,21);
  405.   Str(a,aa); Str(b,bb); Str(c,cc);
  406.   for i:=0 to d-1 do
  407.     dd:= Concat(dd,'0');
  408.   dd:= Concat(aa,bb,cc,dd);
  409.   VAL(dd,wert,dummy);
  410.   WriteLn;
  411.   Write(wert:10:1,' Ohm mit ');
  412.   IF tol = 0 Then tol1 := '+- 1%'
  413.   Else IF tol = 1 Then tol1 := '+- 2%'
  414.   Else IF tol = 2 Then tol1 := '+- 0.5%'
  415.   Else tol1 := 'keine Angabe';
  416.   WriteLn(tol1,' Tolleranz');
  417.   WriteLn('oder');
  418.   If wert > 1E6 Then BEGIN
  419.      wert := wert / 1E6;
  420.      WriteLn(wert:10:1,' MOhm mit ',tol1,' Tolleranz');
  421.   End
  422.   Else
  423.   If wert > 1E3 Then BEGIN
  424.      wert := wert / 1E3;
  425.      WriteLn(wert:10:1,' KOhm mit ',tol1,' Tolleranz');
  426.   End;
  427.   WriteLn;
  428.   WriteLn('weiter Taste drücken !!');
  429.   taste;
  430. End;
  431.  
  432. Procedure Eingabe_Wert_Kohle;
  433. { Eingabe des Widerstandwertes
  434.   sowie das Anpassen des Wertes
  435.   an 3 Farbringe               }
  436. VAR
  437.    I : Integer;
  438.    aa,bb,cc : String[10];
  439. BEGIN
  440.   Window(1,1,80,25);
  441.   ClrScr;
  442.   aa := '';
  443.   Fensterrahmen(2,14,78,22,1,2,7,0,
  444.   '╡ Wert des Kohleschichtwiderstandes ╞');
  445.   Window(20,16,70,21);
  446.   WriteLn('Bitte den Wert des Widerstandes in Ohm eingeben !! ');
  447.   WriteLn;
  448.   Write('Wert ? : ');
  449.   ReadLN(aa);
  450.   VAL(aa,I,dummy);
  451.   IF I < 10 Then aa:=Concat('0',aa);
  452.   WriteLn;
  453.   WriteLn('Bitte den Wert der Tolleranz in % eingeben !!');
  454.   WriteLn('10 oder 5 oder 2 oder 20  eingeben !!');
  455.   WriteLn;
  456.   Write('Wert ? : ');
  457.   ReadLN(bb);
  458.   cc:=copy(aa,1,1);
  459.   VAL(cc,I,dummy);
  460.   Fensterrahmen(2,2,78,10,1,2,7,0,'╡ Widerstand ╞');
  461.   widerstand;
  462.   ring(1,I);
  463.   cc:=copy(aa,2,1);
  464.   VAL(cc,I,dummy);
  465.   ring(2,I);
  466.   I:=length(aa)-2;
  467.   ring(3,I);
  468.   IF bb = '10' THEN I := 0
  469.   Else IF bb = '5' THEN I := 1
  470.   Else IF bb = '2' THEN I := 2
  471.   Else I := 3;
  472.   ring(5,I+10);
  473.   Fensterrahmen(2,14,78,22,1,2,7,0,
  474.   '╡ Wert des Kohleschichtwiderstandes ╞');
  475.   Window(20,16,70,21);
  476.   WriteLn;
  477.   WriteLn('  ',aa,' Ohm ',bb,'% Tolleranz');
  478.   WriteLn;
  479.   WriteLn('  weiter Taste drücken !!!');
  480.   taste;
  481. End;
  482.  
  483. Procedure Eingabe_Wert_Metall;
  484. { Eingabe des Widerstandwertes
  485.   sowie das Anpassen des Wertes
  486.   an 4 Farbringe               }
  487. VAR
  488.    I : Integer;
  489.    aa,bb,cc : String[10];
  490. BEGIN
  491.   Window(1,1,80,25);
  492.   ClrScr;
  493.   aa := '';
  494.   Fensterrahmen(2,14,78,22,1,2,7,0,
  495.   '╡ Wert des Metallschichtwiderstandes ╞');
  496.   Window(20,16,70,21);
  497.   WriteLn('Bitte den Wert des Widerstandes in Ohm eingeben !! ');
  498.   WriteLn;
  499.   Write('Wert ? : ');
  500.   ReadLN(aa);
  501.   VAL(aa,I,dummy);
  502.   IF (I < 100) AND ( I >= 10) Then aa:=Concat('0',aa)
  503.   Else IF I < 10 Then aa:=Concat('00',aa);
  504.   WriteLn;
  505.   WriteLn('Bitte den Wert der Tolleranz in % eingeben !!');
  506.   WriteLn('1 oder 2 oder 0.5  eingeben !!');
  507.   WriteLn;
  508.   Write('Wert ? : ');
  509.   ReadLN(bb);
  510.   cc:=copy(aa,1,1);
  511.   VAL(cc,I,dummy);
  512.   Fensterrahmen(2,2,78,10,1,2,7,0,'╡ Widerstand ╞');
  513.   widerstand;
  514.   ring(1,I);
  515.   cc:=copy(aa,2,1);
  516.   VAL(cc,I,dummy);
  517.   ring(2,I);
  518.   cc:=copy(aa,3,1);
  519.   VAL(cc,I,dummy);
  520.   ring(3,I);
  521.   I:=length(aa)-3;
  522.   ring(4,I);
  523.   IF bb = '1' THEN I := 0
  524.   Else IF bb = '2' THEN I := 1
  525.   Else IF bb = '0.5' THEN I := 2;
  526.   ring(5,I+14);
  527.   Fensterrahmen(2,14,78,22,1,2,7,0,
  528.   '╡ Wert des Kohleschichtwiderstandes ╞');
  529.   Window(20,16,70,21);
  530.   WriteLn;
  531.   WriteLn('  ',aa,' Ohm ',bb,'% Tolleranz');
  532.   WriteLn;
  533.   WriteLn('  weiter Taste drücken !!!');
  534.   taste;
  535. End;
  536.  
  537. Procedure kohle1;
  538. {Farbring --> Wert Kohle }
  539. VAR
  540.    I : Integer;
  541.    Metall : Boolean;
  542. BEGIN
  543.   Metall := FALSE;
  544.   Eingabe_Farbringe(Metall);
  545.   berechne_wert_kohle1;
  546. End;
  547.  
  548. Procedure Metall1;
  549. {Farbring --> Wert Metall }
  550. VAR
  551.    I : Integer;
  552.    Metall : Boolean;
  553. BEGIN
  554.   Metall := TRUE;
  555.   Eingabe_Farbringe(Metall);
  556.   berechne_wert_Metall1;
  557. End;
  558.  
  559. Procedure  Normwert_Servic;
  560. { Procedure sucht in einer gewählten Normreihe (E3 - E192)
  561.   nach einem Widerstand, der dem gewüschten Wert am
  562.   nächsten liegt.
  563.   Widerstandsbereich 0.1 Ohm - 100 MOhm.                  }
  564. VAR
  565.  nr, s, a : Integer;
  566.  wert, xwert, Ralt, Rneu, RG,
  567.  mi, ma, d1, d2, xs : Real;
  568. BEGIN
  569.   Fensterrahmen(15,6,65,22,1,14,7,0,'╡ Normwert Service ╞');
  570.   MenueEingabe1;
  571.   VAL(auswahl,nr,dummy);
  572.   auswahl:=' ';
  573.   REPEAT
  574.     ClrScr;
  575.     WriteLn('Geben Sie den Widerstand ');
  576.     Write('in Ohm ein: ');
  577.     ReadLn(wert);
  578.   Until (wert>=0.1) AND (wert<=1E8);
  579.   ClrScr;
  580.   xwert := 0.1;
  581.   REPEAT
  582.    If xwert <= wert Then xwert := xwert * 10;
  583.   Until xwert > wert;
  584.   xwert := xwert / 10;
  585.   s := 1;
  586.   IF (nr=6) OR (nr=3) Then  s := 2;
  587.   IF (nr=5) OR (nr=2) Then  s := 4;
  588.   IF nr=1 Then  s := 8;
  589.   IF nr>4 Then BEGIN
  590.      a:= -1*S+1;
  591.      Rneu:=xwert;
  592.      REPEAT
  593.        Ralt:=Rneu;
  594.        a:=a+s;
  595.        Rneu:=e192[a]*xwert;
  596.      Until Rneu>wert;
  597.      RG:=Ralt;
  598.      IF (Rneu+Ralt)/2 < wert Then RG:=Rneu;
  599.   End
  600.   Else BEGIN
  601.      a:= -1*S+1;
  602.      Rneu:=xwert;
  603.      REPEAT
  604.        a:=a+s;
  605.        Ralt:=Rneu;
  606.        Rneu:=xwert*e24[a];
  607.      Until Rneu>wert;
  608.      RG:=Ralt;
  609.      IF (Rneu+Ralt)/2 < wert Then RG:=Rneu;
  610.   End;
  611.   WriteLn('A u s g a b e :');
  612.   WriteLn;
  613.   mi := rg - rg*toler[nr]/100;
  614.   ma := rg + rg*toler[nr]/100;
  615.   d1 := (mi-wert)*100/wert;
  616.   d2 := (ma-wert)*100/wert;
  617.   IF (ABS(d2) < ABS(d1)) Then BEGIN
  618.     xs:=d1;
  619.     d1:=d2 ;
  620.     d2:=xs;
  621.   End;
  622.   WriteLn('gewählte Normreihe = ',bezeichnung[nr]);
  623.   WriteLn('gesuchter R-Wert   = ',wert:9:0,' Ohm');
  624.   WriteLn('nächster R-Wert    = ',RG:9:0,' Ohm +- ',toler[nr]:2:1,'%');
  625.   WriteLn('--> min. R-Wert    = ',mi:9:0,' Ohm ');
  626.   WriteLn('--> max. R-Wert    = ',ma:9:0,' Ohm ');
  627.   WriteLn('Abweichung vom Vorgegebenen R-Wert :');
  628.   WriteLn('kleinste Abweichung = ',d1:3:0,'%');
  629.   WriteLn('größte Abweichung   = ',d2:3:0,'%');
  630.   WriteLn;
  631.   WriteLn('weiter Taste drücken !!');
  632.   Taste;
  633. End;
  634.  
  635. Begin   { Hauptprogramm }
  636.  REPEAT
  637.   Fensterrahmen(2,2,78,24,1,2,7,0,
  638.   '╡ Widerstands-Service (c) by Kurt Windolf, Westerland ╞');
  639.   Fensterrahmen(20,7,60,22,3,0,7,0,'╡ Menü ╞');
  640.   MenueEingabe;
  641.   CASE auswahl of
  642.     '1' : kohle1;
  643.     '2' : Eingabe_Wert_Kohle;
  644.     '3' : Metall1;
  645.     '4' : Eingabe_Wert_Metall;
  646.     '5' : Normwert_Servic;
  647.     '6' : EXIT;
  648.   End;
  649.  Until auswahl = '6';
  650. end.