home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / SIMTEL / CPMUG / CPMUG033.ARK / N-ELT1.BAS < prev    next >
BASIC Source File  |  1984-04-29  |  10KB  |  280 lines
  1.  10 REM THIS IS A DIRECTION FINDING ASSISTANCE PROGRAM
  2.  20 REM AND WILL CALCULATE A MEAN FIX AND AN ELLIPSE
  3.  30 REM OF 50 (OR INPUT)PERCENT PROBABILITY CONTOUR FOR MOST LIKELY
  4.  40 REM AREA OF TARGET FIND
  5.  45 REM THIS PROGRAM HAS BEEN ADAPTED TO BASIC-E OR CBASIC
  6.  50 REM WRITTEN BY CHRISTOPHER P. KELLY
  7.  60 REM AMATEUR RADIO EMERGENCY SERVICES
  8.  70 REM ALBUQUERQUE, NEW MEXICO
  9.  80 REM THE VARIABLES USED HERE ARE REPRESENTING THE FOLLOWING
  10.  90 REM EX - STATION X COORDINATE
  11. 100 REM WY - STATION Y COORDINATE
  12. 110 REM BE - BEARING AT THAT STATION
  13. 120 REM SL - SLOPE OF LINE FOR THAT STATION
  14. 130 REM IN - Y INTERCEPT OF LINE FOR THAT STATION
  15. 140 REM CX - CUT X COORDINATE
  16. 150 REM CY - CUT Y COORDINATE
  17. 160 REM NC - NUMBER OF CUTS
  18. 170 REM LA - LATEST BEARING NUMBER
  19. 180 REM DI - DIFFERENCE DEGREES BETWEEN BEARINGS
  20. 190 REM SX - SUM OF X COORDINATES
  21. 200 REM SY - SUM OF Y COORDINATES
  22. 210 REM XM - MEAN X VALUE
  23. 220 REM YM - MEAN Y OF VALUES
  24. 230 REM XV - VARIANCE OF X'S
  25. 240 REM YV - VARIANCE OF Y'S
  26. 250 REM A1-A5 ELEMENTS OF ELLIPSE EQUATION
  27. 260 REM A - ELLIPSE SIZE IN SKEW DIRECTION
  28. 270 REM
  29. 280 REM B - ELLIPSE DIMENSION NORMAL TO SKEW DIRECTION
  30. 290 REM PR - PROBABILITY CONTOUR
  31. 300 DIM EX(30),WY(30),BE(30),SL(30),IN(30)
  32. 310 DIM CX(300),CY(300),X(20),Y(20),Z(20)
  33. 340 PRINT:PRINT:PRINT:PRINT
  34. 350 PRINT " NATIONAL ELT LOCATION TEAM (NELT)":PRINT
  35. 360 PRINT " WELCOME TO THE ELT DF PRAM"
  36. 370 PRINT " THIS PROGRAM WILL PLOT THE ESTIMATED LOCATION "
  37. 380 PRINT " OF A ELT ON AN X,Y COORDINATE SYSTEM, USING"
  38. 390 PRINT " AS INPUT THE X,Y LOCATION OF FIELD TEAMS"
  39. 400 PRINT " AND THEIR BEARINGS TO THE ELT."
  40. 410 PRINT " THE USER MAY ALSO LIST ALL ACCUMULATED CROSSINGS"
  41. 420 PRINT " OF BEARINGS (CUTS) OR CHANGE THE PROBABILITY"
  42. 430 PRINT " PERCENTAGE OF THE ELLEPTICAL PATTERN (A "
  43. 440 PRINT " STATISTICAL MEASURE OF AGREEMENT OF "
  44. 450 PRINT " THE CUTS WITH EACH OTHER). THE PROGRAM CAN ALSO "
  45. 460 PRINT " COMPUTE THE X,Y LOCATION OF THE DF TEAM (IF IT IS"
  46. 470 PRINT " NOT KNOWN) BY USE OF BEACONS OR LANDMARKS"
  47. 480 PRINT
  48. 490 INPUT " TYPE ANY CHARACTER TO CONTINUE";ZZ$
  49. 500 PRINT:PRINT
  50. 510 PRINT "IF COMPASS DECLINATION IS OTHER THAN TRUE "
  51. 520 INPUT "ENTER COMPASS DECLINATION, DEGREES";OF
  52. 530 PRINT:PRINT:PRINT:PRINT:PRINT:PRINT:PRINT
  53. 540 NC=0:LA=0:AO=1000:BO=1000
  54. 550 PR=.5
  55. 560 PRINT " THE FOLLOWING OPTIONS ARE AVAILABLE"
  56. 570 PRINT
  57. 580 PRINT " EDIT   - EDIT DATA ALREADY ENTERED "
  58. 590 PRINT " FIND   - LOCATE FIELD D F TEAM"
  59. 600 PRINT " CHANGE - CHANGE PROBABILITY PERCENTAGE"
  60. 610 PRINT " AVERAGE- BASELINE AVERAGE ROUTINE"
  61. 620 PRINT " COMPUTE- RECOMPUTE WITH CURRENT DATA"
  62. 630 PRINT " MAG    - SET MAGNETIC DECLINATION"
  63. 640 PRINT
  64. 650 INPUT " ENTER COMMAND";BB$
  65. 660 IF BB$ = "EDIT" THEN GOTO 1980
  66. 670 IF BB$ = "FIND" THEN GOTO 1680
  67. 680 IF BB$ = "CHANGE" THEN GOTO 1930
  68. 690 IF BB$ = "COMPUTE" THEN GOTO 880
  69. 700 IF BB$ = "MAG" THEN GOSUB 2770
  70. 710 IF BB$ = "AVERAGE" THEN GOSUB 2380
  71. 720 LA=LA+1
  72. 730 PRINT:INPUT" ENTER FIELD DF TEAM LOCATION X";TM
  73. 740 EX(LA) = TM
  74. 750 IF TM >50 THEN LA=LA-1
  75. 760 IF TM > 50 THEN GOTO 580
  76. 770 INPUT" ENTER FIELD DF TEAM LOCATION Y";WY(LA)
  77. 780 INPUT" ENTER FIELD DF TEAM BEARING TO ELT ";BE(LA)
  78. 790 IF BE(LA)<360 THEN GOTO 810
  79. 800 PRINT "CANCELLING LAST X,Y. REENTER PLEASE ":GOTO 730
  80. 810 BE(LA)=BE(LA)+OF
  81. 820 IF BE(LA)>360 THEN BE(LA)=BE(LA)-360
  82. 830 IF BE(LA) = 180 THEN BE(LA)=179.9
  83. 840 IF BE(LA) = 360 THEN BE(LA)=359.9
  84. 850 IF BE(LA) = 0 THEN BE(LA)=359.9
  85. 860 SL(LA)=TAN((90-BE(LA))/57.2958)
  86. 870 IN(LA)=WY(LA)-(SL(LA)*EX(LA))
  87. 880 IF LA<2 THEN GOTO 720
  88. 890 N1=0
  89. 900 NC=0
  90. 910 FOR I = 1 TO LA-1
  91. 920 FOR J = I+1 TO LA
  92. 930 IA=I
  93. 940 REM FIRST CHECK FOR TWO ANGLES TOO CLOSE
  94. 950 DI=BE(I)-BE(J)
  95. 960 IF ABS(TAN(DI/57.2958)) < .5 THEN GOTO 2270
  96. 970 NC=NC+1
  97. 980 N1=N1+1
  98. 990 CX(NC)=(IN(I)-IN(J))/(SL(J)-SL(I))
  99. 1000 CY(NC)=(SL(J)*CX(NC))+IN(J)
  100. 1010 QQ$="###.##"
  101. 1020 QC$="##"
  102. 1030 QD$="####"
  103. 1040 QB$="####.#"
  104. 1050 PRINT "NEW CUT COORDINATES X,Y";:PRINT USING QQ$;CX(NC);
  105. 1060 PRINT TAB(25);:PRINT USING QQ$;CY(NC)
  106. 1070 NEXT J
  107. 1080 NEXT I
  108. 1090 REM SEE IF WE HAVE ENOUGH CUTS YET
  109. 1100 IF NC<2 THEN GOTO 720
  110. 1110 REM NOW CALCULATE THE SUM OF THE CUTS
  111. 1120 SX=0:SY=0
  112. 1130 FOR I = 1 TO NC
  113. 1140 SX=SX+CX(I)
  114. 1150 SY=SY+CY(I)
  115. 1160 NEXT I
  116. 1170 XM=SX/NC
  117. 1180 YM=SY/NC
  118. 1190 PRINT
  119. 1200 PRINT:PRINT "ESTIMATED ELT LOCATION X=";
  120. 1210 PRINT USING QQ$;XM:
  121. 1220 PRINT "ESTIMATED ELT LOCATION Y=";
  122. 1230 PRINT USING QQ$;YM:PRINT
  123. 1240 IF NC < 3 THEN GOTO 730
  124. 1250 SM=0:XV=0:YV=0
  125. 1260 FOR I = 1 TO NC
  126. 1270 XV=XV+((CX(I)-XM)^2)
  127. 1280 YV=YV+((CY(I)-YM)^2)
  128. 1290 SM=SM+(CX(I)*CY(I))
  129. 1300 NEXT I
  130. 1310 XA=XV/(NC-1)
  131. 1320 YA=YV/(NC-1)
  132. 1330 DX=SQR(XV)
  133. 1340 DY=SQR(YV)
  134. 1350 IF DX*DY = 0 THEN PRINT" ALL CUTS SAME"
  135. 1360 IF DX*DY = 0 THEN GOTO 720
  136. 1370 RH=((SM/NC)-(XM*YM))/(DX*DY)
  137. 1380 SR=(.5*(ATN(2*RH*DX*DY))/(XV-YV))
  138. 1390 SK=90-(SR*57.296)
  139. 1400 IF SK < 0 THEN SK=SK+360
  140. 1410 IF SK >360 THEN SK=SK-360
  141. 1420 REM NOW WE WILL CALCULATE K PROBABILITY CONTOUR
  142. 1430 K=-2*LOG(1-PR)
  143. 1440 REM
  144. 1450 REM BEGIN TO CALCULATE THE BIG ELLIPSE EQUATION
  145. 1460 REM
  146. 1470 A1=(1-RH^2)*K
  147. 1480 A2=(COS(SR)^2)/XA
  148. 1490 A3=(2*RH*SIN(SR)*COS(SR))/(DX*DY)
  149. 1500 A4=(SIN(SR)^2)/YA
  150. 1510 A5=(SIN(SR)^2)/XA
  151. 1520 A6=(COS(SR)^2)/YA
  152. 1530 REM HERE WE GO WITH COMPOSITE EQUATION
  153. 1540 A=A1/(A2-A3+A4)
  154. 1550 B=A1/(A5+A3+A6)
  155. 1560 PRINT "FOR PROBABILITY OF ";PR*100;" PERCENT":PRINT
  156. 1570 PRINT "ELLIPSE A AXIS";:PRINT USING QB$;SK;:PRINT" DEGREES"
  157. 1580 PRINT "ELLIPSE DIMENSION A";:PRINT USING QQ$;A
  158. 1590 PRINT "ELLIPSE DIMENSION B";:PRINT USING QQ$;B
  159. 1600 PRINT
  160. 1610 PRINT
  161. 1620 AO=A
  162. 1630 BO=B
  163. 1640 GOTO 720
  164. 1650 REM THIS SUBPROGRAM IS DESIGNED TO CALCULATE THE
  165. 1660 REM LOCATION OF A SEARCHER IN THE FIELD BY USE
  166. 1670 REM OF HIS BEARINGS TO TWO KNOWN BEACON STATIONS
  167. 1680 PRINT "ENTER FIRST KNOWN LANDMARK OR BEACON X,Y";
  168. 1690 INPUT AX,AY
  169. 1700 PRINT "ENTER BEARING FROM TEAM TO FIRST LANDMARK";
  170. 1710 INPUT B1
  171. 1720 PRINT "ENTER SECOND KNOWN LANDMARK OR BEACON X,Y";
  172. 1730 INPUT BX,BY
  173. 1740 PRINT "ENTER BEARING FROM TEAM TO SECOND LANDMARK";
  174. 1750 INPUT B2
  175. 1760 REM NOW CONVERT BEARINGS TO REVERSE BEARINGS,
  176. 1770 REM FROM BEACON TO SEARCHER
  177. 1780 B1=B1+180
  178. 1790 B2=B2+180
  179. 1800 IF B2 > 360 THEN B2=B2-360
  180. 1810 IF B1 > 360 THEN B1=B1-360
  181. 1820 REM NOW START SOLVING THE LINE INTERCEPTS
  182. 1830 S1=TAN((90-B1)/57.2958)
  183. 1840 S2=TAN((90-B2)/57.2958)
  184. 1850 I1=AY-(S1*AX)
  185. 1860 I2=BY-(S2*BX)
  186. 1870 REM NOW SOLVE FOR SEARCHERS LOCATION
  187. 1880 SX=(I1-I2)/(S2-S1)
  188. 1890 SY=(S1*SX)+I1
  189. 1890 REM HERE WE TELL THE USER WHAT WE FOUND
  190. 1910 PRINT "SEARCHER LOCATION X,Y:";SX,SY
  191. 1920 GOTO 720
  192. 1930 INPUT "ENTER PROBABILITY CONTOUR %";PR
  193. 1940 IF PR < 99.9 AND PR > 1 THEN GOTO 1960
  194. 1950 PRINT " ILLEGAL VALUE, REENTER":GOTO 1930:
  195. 1960 PR=PR/100
  196. 1970 GOTO 1420
  197. 1980 PRINT " DUMP OF BEARINGS:"
  198. 1990 PRINT "NUM   X     Y   MAG BEARING"
  199. 2000 FOR I = 1 TO LA
  200. 2010 PRINT USING QC$;I;:PRINT USING QB$;EX(I);
  201. 2020 PRINT USING QB$;WY(I);:PRINT USING QD$;BE(I)
  202. 2030 NEXT I
  203. 2040 PRINT "COMMANDS: CHANGE(C)-DELETE(D)-OK(O)";
  204. 2050 INPUT BB$
  205. 2060 IF BB$ = "C" THEN GOTO 2090
  206. 2070 IF BB$ = "D" THEN GOTO 2140
  207. 2080 GOTO 720
  208. 2090 INPUT "BEARING NUMBER";BN
  209. 2100 INPUT "ENTER NEW X COORDINATE";EX(BN)
  210. 2110 INPUT "ENTER NEW Y COORDINATE";WY(BN)
  211. 2120 INPUT "ENTER NEW BEARING TO TARGET";BE(BN)
  212. 2130 GOTO 880
  213. 2140 INPUT "DELETE WHICH BEARING (NUMBER)";BN
  214. 2150 IF BN > 0 AND BN <LA THEN GOTO 2180
  215. 2160 IF BN = LA THEN LA=LA-1
  216. 2170 GOTO 720
  217. 2180 FOR I = BN TO LA
  218. 2190 BE(I)=BE(I+1)
  219. 2200 EX(I)=EX(I+1)
  220. 2210 WY(I)=WY(I+1)
  221. 2220 SL(I)=SL(I+1)
  222. 2230 IN(I)=IN(I+1)
  223. 2240 NEXT I
  224. 2250 LA=LA-1
  225. 2260 GOTO 880
  226. 2270 PRINT "THERE IS A TIGHT ANGLE HERE"
  227. 2280 PRINT " BEARINGS:"; BE(LA),BE(IA)
  228. 2290 IF SL(IA)=SL(LA)THEN PRINT "SAME ANGLE-CUT REJECTED"
  229. 2300 IF SL(IA)=SL(LA) THEN GOTO 1080
  230. 2310 PRINT " DO YOU WANT TO KEEP IT";
  231. 2320 INPUT AZ$
  232. 2330 IF AZ$ ="YES" THEN GOTO 970
  233. 2340 GOTO 1080
  234. 2350 REM HERE IS THE BASELINE AVERAGING CODE
  235. 2360 REM
  236. 2370 PRINT
  237. 2380 PRINT "BASELINE AVERAGING WILL AID YOU IN OBTAINING"
  238. 2390 PRINT "A BETTER BEARING IN POOR CONDITIONS, START BY"
  239. 2400 PRINT "ENTERING THE X AND Y LOCATIONS TO BE AVERAGED"
  240. 2410 PRINT "AND THE BEARINGS FROM THOSE LOCATIONS "
  241. 2420 PRINT "IF ALL THE BEARINGS ARE TAKEN FROM THE SAME"
  242. 2430 PRINT"APPROXIMATE LOCATION, THEN ENTER THAT SAME LOCATION"
  243. 2440 PRINT "FOR EACH BEARING. WHEN YOU HAVE ENTERED ALL THE"
  244. 2450 PRINT "INFORMATION YOU HAVE, ENTER A NUMBER GREATER THAN"
  245. 2460 PRINT "50 FOR X, AND THE PROGRAM WILL CALCULATE THE"
  246. 2470 PRINT "AVERAGED LOCATION AND BEARING AND WILL TELL YOU"
  247. 2480 PRINT "THE RESULT AND RETURN YOU TO THE MAIN PROGRAM"
  248. 2490 PRINT "EACH TIME YOU ENTER THIS SUBROUTINE YOU START"
  249. 2500 PRINT "WITH FRESH DATA, NONE IS STORED FROM LAST RUN"
  250. 2510 PRINT
  251. 2520 N=0
  252. 2530 N=N+1
  253. 2540 INPUT "ENTER THE X LOCATION>";X(N)
  254. 2550 IF X(N)>50 THEN GOTO 2590
  255. 2560 INPUT "ENTER THE Y LOCATION>";Y(N)
  256. 2570 INPUT "ENTER THE BEARING>";Z(N)
  257. 2580 GOTO 2530
  258. 2590 N=N-1
  259. 2600 CS=0:SS=0:YY=0:XX=0
  260. 2610 FOR I = 1 TO N
  261. 2620 AN=Z(I)/57.2958
  262. 2630 SS=SS+SIN(AN)
  263. 2640 CS=CS+COS(AN)
  264. 2650 XX=XX+X(I)
  265. 2660 YY=YY+Y(I)
  266. 2670 NEXT I
  267. 2680 SS=SS/N:CS=CS/N:XX=XX/N:YY=YY/N
  268. 2690 AB=ATN(SS/CS)*57.2958
  269. 2700 IF CS<0 THEN AB=AB+180
  270. 2710 IF AB<0 THEN AB=AB+360
  271. 2720 PRINT
  272. 2730 PRINT "AVERAGE X=",XX," AVERAGE Y=",YY
  273. 2740 PRINT "AVERAGE BEARING",AB;" DEGREES"
  274. 2750 PRINT "RETURNING TO MAIN PROGRAM":PRINT
  275. 2760 RETURN
  276. 2770 PRINT:PRINT"CURRENT DECLINATION IS ",OF," DEGREES"
  277. 2780 INPUT "ENTER THE DESIRED DECLINATION";OF
  278. 2790 RETURN
  279. 2800 END
  280.