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 / CPM / HAMRADIO / BEARING.BAS < prev    next >
BASIC Source File  |  2000-06-30  |  2KB  |  83 lines
  1. 10 ' Compute Bearings
  2. 20 ' For The Tandy Model 100
  3. 30 ' adapted from a public domain program
  4. 40 ' by Paul Macdonald v1.2 01/27/85
  5. 50 ' Epson Geneva version in pcs-19 dl6
  6. 60 ' adapted for CP/M by Jim Lill 3 July 87
  7. 70 ' also made small format changes
  8. 80 CLS$=CHR$(26) : ' change this for your terminal
  9. 90 PRINT CLS$
  10. 100 PRINT "Compute Bearings Program"
  11. 110 PRINT "------------------------":PRINT
  12. 120 R=3953*12*5280*.0000254
  13. 130 PI=4*ATN(1)
  14. 140 K=1
  15. 150 KK=2
  16. 160 FOR J=K TO KK
  17. 170 Z$="Destination"
  18. 180 IF J=1 THEN Z$="Source" ELSE PRINT
  19. 190 PRINT"";Z$;" Latitude  (Degs, Mins, N or S)";
  20. 200 INPUT A(J),X,S$
  21. 210 A(J)=PI*((A(J)+X/60)/180)
  22. 220 IF A(J)=0 THEN 270
  23. 230 S$=LEFT$(S$,1)
  24. 240 IF S$="N" OR S$="n" THEN 270
  25. 250 IF S$="S" OR S$="s" THEN A(J)=-A(J):GOTO 270
  26. 260 GOTO 190
  27. 270 PRINT Z$;" Longitude (Degs, Mins, E or W)";
  28. 280 INPUT B(J),X,S$
  29. 290 B(J)=PI*((B(J)+X/60)/180)
  30. 300 IF B(J)=0 OR B(J)=PI THEN 350
  31. 310 S$=LEFT$(S$,1)
  32. 320 IF S$="E" OR S$="e" THEN 350
  33. 330 IF S$="W" OR S$="w" THEN B(J)=-B(J):GOTO 350
  34. 340 GOTO 270
  35. 350 NEXT J
  36. 360 C=COS(A(2))
  37. 370 X=C*COS(B(2))
  38. 380 C=C*SIN(B(2))
  39. 390 D=SIN(A(2))
  40. 400 H=SIN(A(1))
  41. 410 G=COS(B(1))
  42. 420 J=SIN(B(1))
  43. 430 K=COS(A(1))
  44. 440 W=(G*X)+(J*C)
  45. 450 E=(H*W)-(K*D)
  46. 460 F=(G*C)-(J*X)
  47. 470 G=(K*W)+(H*D)
  48. 480 IF ABS(ABS(G)-1)<.00001 THEN 510
  49. 490 W=1-G*G
  50. 500 IF W>0 THEN H=ATN(G/SQR(W)):GOTO 520
  51. 510 H=G*PI/2
  52. 520 IF ABS(ABS(G)-1)<=.00001 OR W<=0 THEN PRINT"Any Angle OK ";:GOTO 630
  53. 530 IF E>0 THEN X=ATN(F/E):GOTO 590
  54. 540 X=PI/2
  55. 550 IF F<=0 THEN X=-X
  56. 560 IF E>=0 THEN 590
  57. 570 X=(ATN(F/E))-PI
  58. 580 IF F>=0 THEN X=X+2*PI
  59. 590 D=180*(PI-X)/PI
  60. 600 C=INT(D+.5)
  61. 610 IF C=360 THEN C=0
  62. 620 PRINT:PRINT "Heading: "C" Degrees ";
  63. 630 PRINT"and "
  64. 640 D=R*(.5*PI-H)
  65. 650 C=INT(D+.5)
  66. 660 PRINT"Range: "C" Kilometers or"
  67. 670 PRINT C*.6215" Miles."
  68. 680 PRINT:PRINT
  69. 690 INPUT"New Source (Y/N)";Y$(1)
  70. 700 INPUT"New Destination (Y/N)";Y$(2)
  71. 710 IF Y$(1)<>"Y" AND Y$(2)<>"Y" THEN GOTO 730
  72. 720 GOTO 740
  73. 730 IF Y$(1)<>"y" AND Y$(2)<>"y" THEN 810
  74. 740 K=1
  75. 750 KK=2
  76. 760 IF Y$(1)<>"Y" AND Y$(1)<>"y" THEN K=2
  77. 770 IF Y$(2)<>"Y" AND Y$(2)<>"y" THEN KK=1
  78. 780 PRINT CLS$:PRINT "Compute Bearings Program"
  79. 790 PRINT "------------------------":PRINT
  80. 800 GOTO 160
  81. 810 PRINT CLS$:PRINT:PRINT "Program Terminated on Request."
  82. 820 END
  83.