home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpmug / cpmug033.ark / DFELT.BAS < prev    next >
Encoding:
BASIC Source File  |  1984-04-29  |  6.5 KB  |  117 lines
  1. REM THIS RADIO DIRECTION FINDING PROGRAM CALCULATES A MEAN FIX AND AN ELLIPSE 
  2. REM OF 50 (OR INPUT) PERCENT PROBABILITY CONTOUR FOR THE MOST LIKELY TARGET 
  3. REM AREA USING UP TO THIRTY LOCATIONS/BEARINGS. THIS PROGRAM (AUTHOR:MJ GREGORY
  4. REM RD10 BOX P-72,CARLISLE PA, PH(717)243-3979) IS A REWRITE IN CBASIC OF THE
  5. REM ORIGINAL PROGRAM 'N-ELT1' WHICH WAS WRITTEN BY C.P.KELLY NEW MEXICO ARES
  6.  
  7. DIM EX(30),WY(30),BE(30),SL(30),IN(30),CX(435),CY(435),X(20),Y(20),Z(20),N$(30)
  8. QQ$=" ####.#":QC$="                ##":QD$="      ###":PR=.5:LA=0
  9. 2770 INPUT "ENTER THE LOCAL EARTH'S MAGNETIC VARIATION IN DEGREES";OF
  10. REM***************************COMMAND MENUE************************************
  11. 580  PRINT:PRINT " THE FOLLOWING OPTIONS ARE AVAILABLE:":PRINT
  12.      PRINT " EDIT   - LIST OR EDIT DATA ALREADY ENTERED "
  13.      PRINT " FIND   - LOCATE FIELD DF TEAM"
  14.      PRINT " PERCENT- CHANGE PROBABILITY PERCENTAGE"
  15.      PRINT " AVERAGE- BASELINE AVERAGE ROUTINE"
  16.      PRINT " COMPUTE- RECOMPUTE WITH CURRENT DATA"
  17.      PRINT " MAG    - SET MAGNETIC DECLINATION"
  18.      PRINT " BEARING- INPUT A NEW BEARING"
  19.      PRINT:INPUT "WHAT IS THE COMMAND NAME PLEASE?";BB$:PRINT
  20.      IF LEFT$(BB$,1)="E" THEN GOSUB 1980            REM EDIT
  21.      IF LEFT$(BB$,1)="F" THEN GOSUB 1680            REM FIND
  22.      IF LEFT$(BB$,1)="P" THEN GOSUB 1930            REM PERCENT
  23.      IF LEFT$(BB$,1)="C" THEN GOSUB 880                REM COMPUTE
  24.      IF LEFT$(BB$,1)="M" THEN GOTO 2770                REM MAG
  25.      IF LEFT$(BB$,1)="A" THEN GOSUB 2380            REM AVERAGE
  26.      IF LEFT$(BB$,1)="B" THEN LA=LA+1:GOSUB 730            REM BEARING
  27.      GOTO 580
  28. REM************************ADDED BEARING ROUTINE*******************************
  29. 730  INPUT" WHAT IS FIELD DF TEAM NAME&LOCATION (X,Y)";N$(LA),EX(LA),WY(LA)
  30.      INPUT"ENTER THE DF TEAM MAGNETIC BEARING TO ELT";BE(LA):BE(LA)=BE(LA)+OF
  31.      IF BE(LA)>360 THEN BE(LA)=BE(LA)-360    REM BE()=BEARING AT STATION
  32.      IF BE(LA)=180 OR BE(LA)=360 THEN BE(LA)=BE(LA)-.1
  33.      IF BE(LA)=0 THEN BE(LA)=359.9        REM SL()=SLOPE OF LINE
  34.      SL(LA)=TAN((90-BE(LA))/57.2958):IN(LA)=WY(LA)-SL(LA)*EX(LA):RETURN
  35. REM************************COMPUTATION ROUTINE*********************************
  36. 880  IF LA<2 THEN PRINT "I NEED ANOTHER BEARING":RETURN
  37.      NC=0:SX=0:SY=0:SM=0:XV=0:YV=0        REM EX()=STATION X COORD
  38.      FOR I=1 TO LA-1                REM LA=LAST BEARING NUMBER
  39.        FOR J=I+1 TO LA                REM WY()=STATION Y COORD
  40.     DI=BE(I)-BE(J)                REM ARE DF ANGLES TOO CLOSE?
  41.     IF ABS(TAN(DI/57.2958))>.5 THEN GOTO 970
  42.     PRINT "HERE'S A TIGHT ANGLE  BEARINGS:";BE(I);"(TEAM:";\
  43.             N$(I);") AND ";BE(J);"(TEAM:";N$(J);")"
  44.     IF SL(I)=SL(J) THEN PRINT "SAME ANGLE-CUT REJECTED":GOTO 1080
  45.     INPUT "DO YOU WANT TO KEEP IT (Y/N)?";AZ$
  46.     IF LEFT$(AZ$,1)<>"Y" THEN GOTO 1080
  47. 970    NC=NC+1                    REM NC=NUMBER OF CUTS
  48.     CX(NC)=(IN(I)-IN(J))/(SL(J)-SL(I))    REM CX()=CUT X COORD
  49.     CY(NC)=SL(J)*CX(NC)+IN(J)        REM CY()=CUT Y COORD
  50.     PRINT USING "&"+QQ$+"&"+QQ$+" & & & &";"NEW CUT COORDINATES X,Y=",\
  51.             CX(NC),",",CY(NC),"USING TEAM",N$(I),"AND TEAM",N$(J)
  52. 1080   NEXT J
  53.      NEXT I
  54.      IF NC<2 THEN PRINT "I NEED MORE CUTS":RETURN
  55.      FOR I=1 TO NC:SX=SX+CX(I):SY=SY+CY(I):NEXT I
  56.      XM=SX/NC:YM=SY/NC            REM XM=MEAN X VALUE;YM=MEAN Y VALUE
  57.      PRINT:PRINT USING "&"+QQ$+"&"+QQ$;"ESTIMATED ELT LOCATION X,Y=",XM,",",YM
  58.      IF NC<3 THEN PRINT "I'LL NEED MORE BEARINGS":RETURN
  59.      FOR I=1 TO NC:XV=XV+(CX(I)-XM)*(CX(I)-XM)        REM XV=VARIANCE OF X'S
  60.            YV=YV+(CY(I)-YM)*(CY(I)-YM)        REM YV=VARIANCE OF Y'S
  61.            SM=SM+CX(I)*CY(I):NEXT I
  62.      XA=XV/(NC-1):YA=YV/(NC-1):DX=SQR(XV):DY=SQR(YV)
  63.      IF DX*DY=0 THEN PRINT" ALL CUTS ARE THE SAME":RETURN
  64.      RH=(SM/NC-XM*YM)/(DX*DY):SR=.5*ATN(2*RH*DX*DY)/(XV-YV):SK=90-SR*57.296
  65.      IF SK<0 OR SK>360 THEN SK=SK-SGN(SK)*360
  66.      K=-2*LOG(1-PR)                REM K=PROBABILITY CONTOUR
  67. REM CALCULATE THE BIG ELLIPSE EQUATION
  68.     A1=(1-RH*RH)*K:A2=COS(SR)*COS(SR)/XA:A3=2*RH*SIN(SR)*COS(SR)/(DX*DY)
  69.     A4=SIN(SR)*SIN(SR)/YA:A5=SIN(SR)*SIN(SR)/XA:A6=COS(SR)*COS(SR)/YA
  70.     A=A1/(A2-A3+A4):B=A1/(A5+A3+A6)    REM COMPOSITE EQUATION CALCULATION
  71.     PRINT:PRINT "FOR A PROBABILITY OF ";PR*100;" PERCENT"
  72.     PRINT USING "& ### &";"THE ELLIPSE SKEW ANGLE IS",SK,"DEGREES"
  73.     PRINT USING "&"+QQ$;"THE ELLIPSE MAJOR AXIS DIMENSION IS",A
  74.     PRINT USING "&"+QQ$;"THE LLIPSE MINOR AXIS DIMENSION IS",B:RETURN
  75. REM**************************DF TEAM LOCATION**********************************
  76. 1680 INPUT "ENTER THE FIRST KNOWN LANDMARK OR BEACON X,Y";AX,AY
  77.      INPUT "ENTER THE BEARING FROM TEAM TO FIRST LANDMARK";B1:B1=B1+OF
  78.      INPUT "ENTER THE SECOND KNOWN LANDMARK OR BEACON X,Y";BX,BY
  79.      INPUT "ENTER THE BEARING FROM TEAM TO SECOND LANDMARK";B2:B2=B2+OF
  80.      IF B2>180 THEN B2=B2-180 ELSE B2=B2+180        REM REVERSE BEARINGS
  81.      IF B1>180 THEN B1=B1-180 ELSE B1=B1+180        REM REVERSE BEARINGS
  82.      S1=TAN((90-B1)/57.2958):S2=TAN((90-B2)/57.2958)
  83.      I1=AY-(S1*AX):I2=BY-(S2*BX):SX=(I1-I2)/(S2-S1)
  84.      PRINT USING "&"+QQ$+QQ$; "DF TEAM LOCATION X,Y IS";SX,S1*SX+I1:RETURN
  85. REM*************************PERCENT ROUTINE************************************
  86. 1930 INPUT "ENTER PROBABILITY CONTOUR %";PR:PR=PR/100
  87.      IF PR>.999 OR PR<.01 THEN GOTO 1930 ELSE RETURN
  88. REM***************************EDIT ROUTINE*************************************
  89. 1980 PRINT "DUMP OF BEARINGS:NUM   X      Y   MAG BEARING   TEAM"
  90.      FOR I=1 TO LA
  91.     PRINT USING QC$+QQ$+QQ$+QD$+"        &";I,EX(I),WY(I),BE(I),N$(I)
  92.      NEXT I
  93.      INPUT "COMMANDS: CHANGE(C)-DELETE(D)-OK(O)   WHICH ONE?";BB$
  94.      IF BB$="C" THEN INPUT "BEARING NUMBER?";BN:INPUT"TEAM NAME?";N$(BN):\
  95.         INPUT "NEW X COORDINATE?,Y COORDINATE?";EX(BN),WY(BN):\
  96.         INPUT "NEW BEARING TO TARGET?";BE(BN) : BE(BN)=BE(BN)+OF:\
  97.         SL(BN)=TAN((90-BE(BN))/57.2958):IN(BN)=WY(BN)-SL(BN)*EX(BN):\
  98.         PRINT:PRINT:GOTO 1980
  99.      IF BB$<>"D" THEN RETURN ELSE INPUT "DELETE WHICH BEARING (NUMBER)?";BN
  100.      FOR I=BN TO LA:N$(I)=N$(I+1):BE(I)=BE(I+1):EX(I)=EX(I+1)
  101.             WY(I)=WY(I+1):SL(I)=SL(I+1):IN(I)=IN(I+1):NEXT I
  102.      LA=LA-1:PRINT:PRINT:GOTO 1980            REM BEARING NOW DELETED
  103. REM*********************BASELINE AVERAGING ROUTINE*****************************
  104. 2380 N=1:CS=0:SS=0:YY=0:XX=0        REM NO MORE THAN 30 LOCATIONS/BEARINGS
  105. 2530 INPUT "ENTER THE X LOCATION,Y LOCATION,BEARING>";X(N),Y(N),Z(N)
  106.      INPUT "DO YOU HAVE ANOTHER LOCATION/BEARING? (Y/N)?";AZ$
  107.      IF LEFT$(AZ$,1)="Y" THEN N=N+1:GOTO 2530
  108.      FOR I=1 TO N
  109.     AN=Z(I)/57.2958:SS=SS+SIN(AN):CS=CS+COS(AN):XX=XX+X(I):YY=YY+Y(I)
  110.      NEXT I
  111.      XX=XX/N:YY=YY/N:AB=ATN(SS/CS)*57.2958
  112.      IF CS/N<0 THEN AB=AB+180
  113.      IF AB<0 THEN AB=AB+360
  114.      PRINT USING "&"+QQ$+"&"+QQ$;"AVERAGE X,Y=";XX;",";YY,
  115.      PRINT USING "&### &";"  AVERAGE BEARING IS=";AB;"DEGREES":RETURN
  116. END
  117.