home *** CD-ROM | disk | FTP | other *** search
/ WinWares 1 / WINWARES.ISO / calc / tablecrv / basica.tcl next >
Encoding:
Text File  |  1993-06-01  |  7.9 KB  |  239 lines
  1. ~~BASICA~~
  2. 10  '--------------------------------------------------------------
  3. 20  '             TableCurve BASICA Library Module
  4. 30  '--------------------------------------------------------------
  5. 40  ' This code is specific to BASICA/GWBASIC. BASICA's double
  6. 50  ' precision differs from most other languages. Its range is 
  7. 60  ' limited to 1D-38 to 1D+38 although there are 15 digits
  8. 70  ' precision. To have all math functions performed using double-
  9. 80  ' precision, it is necessary to start BASICA on the command
  10. 90  ' line with the /D option. 
  11. 100 '--------------------------------------------------------------
  12. 110 ' The polynomial and rational equations use a polynomial 
  13. 120 ' calculation subroutine rather than coding the equation on a 
  14. 130 ' single line. Such single line expressions are too complex for
  15. 140 ' BASICA to evaluate.
  16. 150 '--------------------------------------------------------------
  17. 160 DEFDBL X,Y : DEFINT I,J
  18. 170 DIM COEF#(11)`FPNRT`
  19. 180 DIM X(17),Y(17)
  20. 190 KEY OFF
  21. 200 FORE1%=1 : BACK1%=7 : FORE2%=15 : BACK2%=1
  22. 210 COLOR FORE1%,BACK1%,BACK1% : CLS
  23. 220 LOCATE 1,2 : PRINT CHR$(201);
  24. 230 LOCATE 25,2 : PRINT CHR$(200);
  25. 240 LOCATE 1,79 : PRINT CHR$(187);
  26. 250 LOCATE 25,79 : PRINT CHR$(188);
  27. 260 FOR I=3 TO 78 : LOCATE 1,I : PRINT CHR$(205); : NEXT I
  28. 270 FOR I=3 TO 78 : LOCATE 25,I : PRINT CHR$(205); : NEXT I
  29. 280 FOR I=2 TO 24 : LOCATE I,2 : PRINT CHR$(186); : NEXT I
  30. 290 FOR I=2 TO 24 : LOCATE I,79 : PRINT CHR$(186); : NEXT I
  31. 300 LOCATE 1,`POSN1` 
  32. 310 PRINT " TableCurve Subroutine: `FILE` `DATE` `TIME` ";
  33. 320 COLOR FORE2%,BACK2%,BACK2%
  34. 330 FOR I=5 TO 23 : LOCATE I,33 : PRINT SPACE$(45); : NEXT I
  35. 340 LOCATE 5,33 : PRINT CHR$(218);
  36. 350 LOCATE 24,33 : PRINT CHR$(192);
  37. 360 LOCATE 5,77 : PRINT CHR$(191);
  38. 370 LOCATE 24,77 : PRINT CHR$(217);
  39. 380 FOR I=34 TO 76 : LOCATE 5,I : PRINT CHR$(196); : NEXT I
  40. 390 FOR I=34 TO 76 : LOCATE 24,I : PRINT CHR$(196); : NEXT I
  41. 400 FOR I=6 TO 23 : LOCATE I,33 : PRINT CHR$(179); : NEXT I
  42. 410 FOR I=6 TO 23 : LOCATE I,77 : PRINT CHR$(179); : NEXT I
  43. 420 LOCATE 5,`POSN2` : PRINT " `TITLE` ";
  44. 430 LOCATE 6,35 : PRINT "`XTITLE`";
  45. 440 LOCATE 6,57 : PRINT "`YTITLE`";
  46. 450 COLOR FORE1%,BACK1%,BACK1%
  47. 460 LOCATE 3,4  : PRINT "`EQSTR`";
  48. 470 LOCATE 4,6  : PRINT "Eqn# `EQNO`";
  49. 480 LOCATE 5,6  : PRINT "r2=`R2VAL`";
  50. 490 LOCATE 6,6  : PRINT "a= `ASTR`";
  51. 500 LOCATE 7,6  : PRINT "b= `BSTR`";
  52. 510 LOCATE 8,6  : PRINT "c= `CSTR`";
  53. 520 LOCATE 9,6  : PRINT "d= `DSTR`";
  54. 530 LOCATE 10,6 : PRINT "e= `ESTR`";
  55. 540 LOCATE 11,6 : PRINT "f= `FSTR`";
  56. 550 LOCATE 12,6 : PRINT "g= `GSTR`";
  57. 560 LOCATE 13,6 : PRINT "h= `HSTR`";
  58. 570 LOCATE 14,6 : PRINT "i= `ISTR`";
  59. 580 LOCATE 15,6 : PRINT "j= `JSTR`";
  60. 590 LOCATE 16,6 : PRINT "k= `KSTR`";
  61. 600 LOCATE 18,4 : PRINT "X= `XTITLE`";
  62. 610 LOCATE 19,4 : PRINT "Y= `YTITLE`";
  63. 620 LOCATE 21,4 : PRINT "Enter Value [x=,y=]";
  64. 630 LOCATE 24,4 : PRINT "Press ESC to End Program";
  65. 640 IROW=7
  66. 650 IATMAX=0
  67. 660 ON ERROR GOTO 880
  68. 670 J=IROW-6
  69. 680 COLOR FORE2%,BACK2%,BACK2%
  70. 690 NFLD$="": ROWFLD=22: COLFLD=4: MAXLEN=25: STATUS=0
  71. 700 GOSUB 11500
  72. 710 IF STATUS=0 THEN 890
  73. 720 IF STATUS>0 THEN X(J)=VAL(NFLD$):X=X(J):GOSUB 10000:Y(J)=Y:GOTO 750
  74. 730 IF IDIR=1 THEN IDIR=0 ELSE IDIR=1
  75. 740 YR=VAL(NFLD$) : GOSUB 11000 : X(J)=X : Y(J)=YR 
  76. 750 IF IROW=23 THEN LOCATE 23,34 : PRINT SPACE$(42);
  77. 760 LOCATE IROW,35
  78. 770 FMT$="########.########"
  79. 780 IF ABS(X(J))>1E+07 OR ABS(X(J))<.0001 THEN FMT$="   +#.#######^^^^"
  80. 790 PRINT USING FMT$;X(J);
  81. 800 LOCATE IROW,57
  82. 810 FMT$="########.########"
  83. 820 IF ABS(Y(J))>1E+07 OR ABS(Y(J))<.0001 THEN FMT$="   +#.#######^^^^"
  84. 830 PRINT USING FMT$;Y(J);
  85. 840 IROW=IROW+1
  86. 850 IF IROW>23 THEN IROW=23:IATMAX=1
  87. 860 COLOR FORE1%,BACK1%,BACK1%
  88. 870 GOTO 670
  89. 880 RESUME 670
  90. 890 CLS
  91. 900 SYSTEM
  92. 910 END
  93.  
  94. !!BASICA!!
  95. 10000 'TableCurve Subroutine:`FILE` `DATE` `TIME`
  96. 10010 '`TITLE`
  97. 10020 'X= `XTITLE`
  98. 10030 'Y= `YTITLE`
  99. 10040 'Eqn# `EQNO`  `EQSTR`
  100. 10050 'r2=`R2VAL`
  101. 10060 'r2adj=`R2ADJ`
  102. 10070 'StdErr=`STDERR`
  103. 10080 'Fval=`Fval`
  104. 10090 'a= `ASTR`
  105. 10100 'b= `BSTR`
  106. 10110 'c= `CSTR`
  107. 10120 'd= `DSTR`
  108. 10130 'e= `ESTR`
  109. 10140 'f= `FSTR`
  110. 10150 'g= `GSTR`
  111. 10160 'h= `HSTR`
  112. 10170 'i= `ISTR`
  113. 10180 'j= `JSTR`
  114. 10190 'k= `KSTR`
  115. 10200 `SCOPE`DIM COEF#(11)`FPNRT`
  116. 10210 OLDX#=X#
  117. 10220 X#=`FX`
  118. 10230 N#=`FBAL2`
  119. 10240 N#=`FAUX`
  120. 10250 COEF#(1)=`PBb`
  121. 10260 COEF#(2)=`PBd`
  122. 10270 COEF#(3)=`PBf`
  123. 10280 COEF#(4)=`PBh`
  124. 10290 COEF#(5)=`PBj`
  125. 10300 ORDER%=`ORDPB1` : GOSUB 10900 : Y1#=X#*YPN#`LISTPB`
  126. 10305 XN#=X# : X#=N#`LISTPB`
  127. 10310 COEF#(1)=`PBa`
  128. 10320 COEF#(2)=`PBc`
  129. 10330 COEF#(3)=`PBe`
  130. 10340 COEF#(4)=`PBg`
  131. 10350 COEF#(5)=`PBi`
  132. 10360 COEF#(6)=`PBk`
  133. 10370 ORDER%=`ORDPB2` : GOSUB 10900 : Y2#=YPN#`LISTPB`
  134. 10375 X#=XN#`LISTPB`
  135. 10380 Y#=Y1#+Y2#`LISTPB`
  136. 10390 COEF#(1)=`RTa`
  137. 10400 COEF#(2)=`RTc`
  138. 10410 COEF#(3)=`RTe`
  139. 10420 COEF#(4)=`RTg`
  140. 10430 COEF#(5)=`RTi`
  141. 10440 COEF#(6)=`RTk`
  142. 10450 ORDER%=`ORDRTN` : GOSUB 10900`LISTRT`
  143. 10460 YNUM#=YPN#`LISTRT`
  144. 10470 COEF#(1)=`RTb`
  145. 10480 COEF#(2)=`RTd`
  146. 10490 COEF#(3)=`RTf`
  147. 10500 COEF#(4)=`RTh`
  148. 10510 COEF#(5)=`RTj`
  149. 10520 ORDER%=`ORDRTD` : GOSUB 10900`LISTRT`
  150. 10530 Y#=YNUM#/(1.0+X#*YPN#)`LISTRT` 
  151. 10540 COEF#(1)= `PNa`
  152. 10550 COEF#(2)= `PNb`
  153. 10560 COEF#(3)= `PNc`
  154. 10570 COEF#(4)= `PNd`
  155. 10580 COEF#(5)= `PNe`
  156. 10590 COEF#(6)= `PNf`
  157. 10600 COEF#(7)= `PNg`
  158. 10610 COEF#(8)= `PNh`
  159. 10620 COEF#(9)= `PNi`
  160. 10630 COEF#(10)=`PNj`
  161. 10640 COEF#(11)=`PNk`
  162. 10650 ORDER%=`ORDPN` : GOSUB 10900`LISTPN`
  163. 10660 Y#=YPN#`LISTPN` 
  164. 10665 ERFBAS#=`ERFBAS`
  165. 10670 Z=ABS(ERFBAS#)
  166. 10680  T=1.0/(1.0+0.5*Z)
  167. 10690  ANS=T*(-1.13520398+T*(1.48851587+T*(-.82215223+T*.17087277)))
  168. 10700  ANS=T*(.09678418+T*(-.18628806+T*(.27886807+ANS)))
  169. 10710  ANS=(T*EXP(-Z*Z-1.26551223+T*(1.00002368+T*(.37409196#+ANS))))
  170. 10720  IF ERFBAS#>=0.0 THEN ERF#=1.0-ANS ELSE ERF#=-1.0+ANS
  171. 10730 DEF FNERF#(X#)=ERF#
  172. 10740 X1#=`F1`
  173. 10750 X2#=`F2`
  174. 10760 X3#=`F3`
  175. 10770 X4#=`F4`
  176. 10780 Y#=`EQNCODE`
  177. 10790 Y#=`FY`
  178. 10800 X#=OLDX#
  179. 10810 RETURN
  180.  
  181. 10900 'Polynomial Calculation Subroutine`FPNRT`
  182. 10910 YPN#=COEF#(ORDER%+1)`FPNRT`
  183. 10920 FOR ITER%=ORDER% TO 1 STEP -1`FPNRT`
  184. 10930 YPN#= YPN#*X#+COEF#(ITER%)`FPNRT`
  185. 10940 NEXT ITER%`FPNRT`
  186. 10950 RETURN`FPNRT`
  187.  
  188. !!BASICA!!
  189.  
  190. 11000 'Root Find Routine Using Bi-section Method
  191. 11010 XACC=1E-6*`XMEAN` 
  192. 11020 XINC=`XRANGE`/4
  193. 11030 FOR I=0 TO 4
  194. 11040 IF I=4 THEN XV1=`XATYMIN`: XV2=`XATYMAX` :GOTO 11070
  195. 11050 IF IDIR=1 THEN XV2=`XMAXIMUM`-XINC*I : XV1=`XMAXIMUM`-XINC*(I+1): GOTO 11070
  196. 11060 XV1=`XMINIMUM`+XINC*I : XV2=`XMINIMUM`+XINC*(I+1)
  197. 11070 X=XV1 : GOSUB 10000 : XF=YR-Y 
  198. 11080 X=XV2 : GOSUB 10000 : XM=YR-Y
  199. 11090 IF XF*XM>=0 THEN 11190
  200. 11100 IF XF<0.0 THEN XD=XV2-XV1 : XRTB=XV1 : GOTO 11120
  201. 11110 XD=XV1-XV2 : XRTB=XV2
  202. 11120 FOR IJ=1 TO 100
  203. 11130 XD=XD*0.5
  204. 11140 XMID=XRTB+XD
  205. 11150 X=XMID : GOSUB 10000 : XM=YR-Y
  206. 11160 IF XM<=0 THEN XRTB=XMID
  207. 11170 IF ABS(XD)<XACC OR XM=0 THEN X=XRTB : Y=YR : GOTO 11210
  208. 11180 NEXT IJ
  209. 11190 NEXT I
  210. 11200 X=0 : Y=YR
  211. 11210 RETURN
  212.  
  213. 11500 'Numeric Input Subroutine, Fills NFLD$ with entry
  214. 11510 LOCATE ROWFLD,COLFLD,1: PRINT SPACE$(MAXLEN);
  215. 11520 LOCATE ROWFLD,COLFLD,1
  216. 11530 ICHAR=0 : IYFLAG=0 : IEXP=0
  217. 11540 C=ASC(INPUT$(1))
  218. 11550 IPASS=0
  219. 11560 IF ICHAR=0 AND (C=89 OR C=121) THEN IYFLAG=1: IPASS=1
  220. 11570 IF ICHAR=0 AND (C=88 OR C=120) THEN IPASS=1
  221. 11580 IF ICHAR=1 AND C=61 THEN IPASS=1
  222. 11590 IF((C>=48 AND C<=57) OR C=45 OR C=43 OR C=46 OR ((C=69 OR C=101) AND IEXP=0) OR IPASS=1) THEN 11600 ELSE 11650
  223. 11600 IF IPASS=0 THEN NFLD$=NFLD$+CHR$(C)
  224. 11610 IF C=69 OR C=101 THEN IEXP=1
  225. 11620 LOCATE ROWFLD,COLFLD+ICHAR,1: PRINT CHR$(C);
  226. 11630 LOCATE ROWFLD,COLFLD+ICHAR+1,1
  227. 11640 ICHAR=ICHAR+1
  228. 11650 IF((C=10 OR C=13 OR ICHAR=MAXLEN) AND ICHAR>0) THEN 11730
  229. 11660 IF(C=8 AND ICHAR>0) THEN 11670 ELSE 11710
  230. 11670 ICHAR=ICHAR-1: IF ICHAR=0 THEN IYFLAG=0
  231. 11680 LOCATE ROWFLD,COLFLD+ICHAR,1: PRINT CHR$(32);
  232. 11690 LOCATE ROWFLD,COLFLD+ICHAR,1
  233. 11700 IF LEN(NFLD$)>0 THEN NFLD$=LEFT$(NFLD$,LEN(NFLD$)-1) 
  234. 11710 IF(C=27) THEN ICHAR=0 : GOTO 11730
  235. 11720 IF(ICHAR<MAXLEN) GOTO 11540
  236. 11730 IF IYFLAG=0 THEN STATUS=ICHAR ELSE STATUS=-ICHAR
  237. 11740 RETURN
  238. ~~BASICA~~
  239.