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
/
DFELT.BAS
< prev
next >
Wrap
BASIC Source File
|
1984-04-29
|
7KB
|
117 lines
REM THIS RADIO DIRECTION FINDING PROGRAM CALCULATES A MEAN FIX AND AN ELLIPSE
REM OF 50 (OR INPUT) PERCENT PROBABILITY CONTOUR FOR THE MOST LIKELY TARGET
REM AREA USING UP TO THIRTY LOCATIONS/BEARINGS. THIS PROGRAM (AUTHOR:MJ GREGORY
REM RD10 BOX P-72,CARLISLE PA, PH(717)243-3979) IS A REWRITE IN CBASIC OF THE
REM ORIGINAL PROGRAM 'N-ELT1' WHICH WAS WRITTEN BY C.P.KELLY NEW MEXICO ARES
DIM EX(30),WY(30),BE(30),SL(30),IN(30),CX(435),CY(435),X(20),Y(20),Z(20),N$(30)
QQ$=" ####.#":QC$=" ##":QD$=" ###":PR=.5:LA=0
2770 INPUT "ENTER THE LOCAL EARTH'S MAGNETIC VARIATION IN DEGREES";OF
REM***************************COMMAND MENUE************************************
580 PRINT:PRINT " THE FOLLOWING OPTIONS ARE AVAILABLE:":PRINT
PRINT " EDIT - LIST OR EDIT DATA ALREADY ENTERED "
PRINT " FIND - LOCATE FIELD DF TEAM"
PRINT " PERCENT- CHANGE PROBABILITY PERCENTAGE"
PRINT " AVERAGE- BASELINE AVERAGE ROUTINE"
PRINT " COMPUTE- RECOMPUTE WITH CURRENT DATA"
PRINT " MAG - SET MAGNETIC DECLINATION"
PRINT " BEARING- INPUT A NEW BEARING"
PRINT:INPUT "WHAT IS THE COMMAND NAME PLEASE?";BB$:PRINT
IF LEFT$(BB$,1)="E" THEN GOSUB 1980 REM EDIT
IF LEFT$(BB$,1)="F" THEN GOSUB 1680 REM FIND
IF LEFT$(BB$,1)="P" THEN GOSUB 1930 REM PERCENT
IF LEFT$(BB$,1)="C" THEN GOSUB 880 REM COMPUTE
IF LEFT$(BB$,1)="M" THEN GOTO 2770 REM MAG
IF LEFT$(BB$,1)="A" THEN GOSUB 2380 REM AVERAGE
IF LEFT$(BB$,1)="B" THEN LA=LA+1:GOSUB 730 REM BEARING
GOTO 580
REM************************ADDED BEARING ROUTINE*******************************
730 INPUT" WHAT IS FIELD DF TEAM NAME&LOCATION (X,Y)";N$(LA),EX(LA),WY(LA)
INPUT"ENTER THE DF TEAM MAGNETIC BEARING TO ELT";BE(LA):BE(LA)=BE(LA)+OF
IF BE(LA)>360 THEN BE(LA)=BE(LA)-360 REM BE()=BEARING AT STATION
IF BE(LA)=180 OR BE(LA)=360 THEN BE(LA)=BE(LA)-.1
IF BE(LA)=0 THEN BE(LA)=359.9 REM SL()=SLOPE OF LINE
SL(LA)=TAN((90-BE(LA))/57.2958):IN(LA)=WY(LA)-SL(LA)*EX(LA):RETURN
REM************************COMPUTATION ROUTINE*********************************
880 IF LA<2 THEN PRINT "I NEED ANOTHER BEARING":RETURN
NC=0:SX=0:SY=0:SM=0:XV=0:YV=0 REM EX()=STATION X COORD
FOR I=1 TO LA-1 REM LA=LAST BEARING NUMBER
FOR J=I+1 TO LA REM WY()=STATION Y COORD
DI=BE(I)-BE(J) REM ARE DF ANGLES TOO CLOSE?
IF ABS(TAN(DI/57.2958))>.5 THEN GOTO 970
PRINT "HERE'S A TIGHT ANGLE BEARINGS:";BE(I);"(TEAM:";\
N$(I);") AND ";BE(J);"(TEAM:";N$(J);")"
IF SL(I)=SL(J) THEN PRINT "SAME ANGLE-CUT REJECTED":GOTO 1080
INPUT "DO YOU WANT TO KEEP IT (Y/N)?";AZ$
IF LEFT$(AZ$,1)<>"Y" THEN GOTO 1080
970 NC=NC+1 REM NC=NUMBER OF CUTS
CX(NC)=(IN(I)-IN(J))/(SL(J)-SL(I)) REM CX()=CUT X COORD
CY(NC)=SL(J)*CX(NC)+IN(J) REM CY()=CUT Y COORD
PRINT USING "&"+QQ$+"&"+QQ$+" & & & &";"NEW CUT COORDINATES X,Y=",\
CX(NC),",",CY(NC),"USING TEAM",N$(I),"AND TEAM",N$(J)
1080 NEXT J
NEXT I
IF NC<2 THEN PRINT "I NEED MORE CUTS":RETURN
FOR I=1 TO NC:SX=SX+CX(I):SY=SY+CY(I):NEXT I
XM=SX/NC:YM=SY/NC REM XM=MEAN X VALUE;YM=MEAN Y VALUE
PRINT:PRINT USING "&"+QQ$+"&"+QQ$;"ESTIMATED ELT LOCATION X,Y=",XM,",",YM
IF NC<3 THEN PRINT "I'LL NEED MORE BEARINGS":RETURN
FOR I=1 TO NC:XV=XV+(CX(I)-XM)*(CX(I)-XM) REM XV=VARIANCE OF X'S
YV=YV+(CY(I)-YM)*(CY(I)-YM) REM YV=VARIANCE OF Y'S
SM=SM+CX(I)*CY(I):NEXT I
XA=XV/(NC-1):YA=YV/(NC-1):DX=SQR(XV):DY=SQR(YV)
IF DX*DY=0 THEN PRINT" ALL CUTS ARE THE SAME":RETURN
RH=(SM/NC-XM*YM)/(DX*DY):SR=.5*ATN(2*RH*DX*DY)/(XV-YV):SK=90-SR*57.296
IF SK<0 OR SK>360 THEN SK=SK-SGN(SK)*360
K=-2*LOG(1-PR) REM K=PROBABILITY CONTOUR
REM CALCULATE THE BIG ELLIPSE EQUATION
A1=(1-RH*RH)*K:A2=COS(SR)*COS(SR)/XA:A3=2*RH*SIN(SR)*COS(SR)/(DX*DY)
A4=SIN(SR)*SIN(SR)/YA:A5=SIN(SR)*SIN(SR)/XA:A6=COS(SR)*COS(SR)/YA
A=A1/(A2-A3+A4):B=A1/(A5+A3+A6) REM COMPOSITE EQUATION CALCULATION
PRINT:PRINT "FOR A PROBABILITY OF ";PR*100;" PERCENT"
PRINT USING "& ### &";"THE ELLIPSE SKEW ANGLE IS",SK,"DEGREES"
PRINT USING "&"+QQ$;"THE ELLIPSE MAJOR AXIS DIMENSION IS",A
PRINT USING "&"+QQ$;"THE LLIPSE MINOR AXIS DIMENSION IS",B:RETURN
REM**************************DF TEAM LOCATION**********************************
1680 INPUT "ENTER THE FIRST KNOWN LANDMARK OR BEACON X,Y";AX,AY
INPUT "ENTER THE BEARING FROM TEAM TO FIRST LANDMARK";B1:B1=B1+OF
INPUT "ENTER THE SECOND KNOWN LANDMARK OR BEACON X,Y";BX,BY
INPUT "ENTER THE BEARING FROM TEAM TO SECOND LANDMARK";B2:B2=B2+OF
IF B2>180 THEN B2=B2-180 ELSE B2=B2+180 REM REVERSE BEARINGS
IF B1>180 THEN B1=B1-180 ELSE B1=B1+180 REM REVERSE BEARINGS
S1=TAN((90-B1)/57.2958):S2=TAN((90-B2)/57.2958)
I1=AY-(S1*AX):I2=BY-(S2*BX):SX=(I1-I2)/(S2-S1)
PRINT USING "&"+QQ$+QQ$; "DF TEAM LOCATION X,Y IS";SX,S1*SX+I1:RETURN
REM*************************PERCENT ROUTINE************************************
1930 INPUT "ENTER PROBABILITY CONTOUR %";PR:PR=PR/100
IF PR>.999 OR PR<.01 THEN GOTO 1930 ELSE RETURN
REM***************************EDIT ROUTINE*************************************
1980 PRINT "DUMP OF BEARINGS:NUM X Y MAG BEARING TEAM"
FOR I=1 TO LA
PRINT USING QC$+QQ$+QQ$+QD$+" &";I,EX(I),WY(I),BE(I),N$(I)
NEXT I
INPUT "COMMANDS: CHANGE(C)-DELETE(D)-OK(O) WHICH ONE?";BB$
IF BB$="C" THEN INPUT "BEARING NUMBER?";BN:INPUT"TEAM NAME?";N$(BN):\
INPUT "NEW X COORDINATE?,Y COORDINATE?";EX(BN),WY(BN):\
INPUT "NEW BEARING TO TARGET?";BE(BN) : BE(BN)=BE(BN)+OF:\
SL(BN)=TAN((90-BE(BN))/57.2958):IN(BN)=WY(BN)-SL(BN)*EX(BN):\
PRINT:PRINT:GOTO 1980
IF BB$<>"D" THEN RETURN ELSE INPUT "DELETE WHICH BEARING (NUMBER)?";BN
FOR I=BN TO LA:N$(I)=N$(I+1):BE(I)=BE(I+1):EX(I)=EX(I+1)
WY(I)=WY(I+1):SL(I)=SL(I+1):IN(I)=IN(I+1):NEXT I
LA=LA-1:PRINT:PRINT:GOTO 1980 REM BEARING NOW DELETED
REM*********************BASELINE AVERAGING ROUTINE*****************************
2380 N=1:CS=0:SS=0:YY=0:XX=0 REM NO MORE THAN 30 LOCATIONS/BEARINGS
2530 INPUT "ENTER THE X LOCATION,Y LOCATION,BEARING>";X(N),Y(N),Z(N)
INPUT "DO YOU HAVE ANOTHER LOCATION/BEARING? (Y/N)?";AZ$
IF LEFT$(AZ$,1)="Y" THEN N=N+1:GOTO 2530
FOR I=1 TO N
AN=Z(I)/57.2958:SS=SS+SIN(AN):CS=CS+COS(AN):XX=XX+X(I):YY=YY+Y(I)
NEXT I
XX=XX/N:YY=YY/N:AB=ATN(SS/CS)*57.2958
IF CS/N<0 THEN AB=AB+180
IF AB<0 THEN AB=AB+360
PRINT USING "&"+QQ$+"&"+QQ$;"AVERAGE X,Y=";XX;",";YY,
PRINT USING "## &";" AVERAGE BEARING IS=";AB;"DEGREES":RETURN
END