[转贴]：附和导线平差程序[QBASIC]

guojintian

DECLARE FUNCTION DEG! (X!)
DECLARE FUNCTION DMS! (XX!)
DECLARE FUNCTION XCHAR$ (XX!, N!)
CLS
PRINT
PRINT " 附和导线平差程序(2.0R)"
PRINT " 作者：徐振刚"
PRINT " 1999年12月31日"
PRINT "功能：本程序可以用来进行一般导线平差计算，包括附和导线、闭合导线和支导线，其中"
PRINT " 闭合导线和支导线需对原始数据进行一定处理。"
PRINT "备注：坐标计算误差≤5mm；角度计算误差≤0.5s"
PRINT

REM N ----角度个数(包括已知方位角)
REM M ----导线边数
REM H ----允许方位角闭合差秒值
REM A ----方位角(A(0)为起始方位角)
REM D ----边长
REM X,Y ----坐标(X1,Y1;X,Y为已知坐标)
REM F0 ----方位角允许闭合差
REM F1 ----导线方位角闭合差
REM F3,F4,F----增量闭合差
REM K ----导线全长相对闭合差

PRINT "新建数据文件?(Y/N)"
LOCATE 25: PRINT "按 ESC键 返回主菜单."; TAB(60); DATE$; " "; TIME$
DO
YN$ = INKEY$
IF YN$ = "Y" OR TN$ = "y" THEN
RUN "DXPCEDIT.BAS"
ELSEIF YN$ = "N" OR YN$ = "n" THEN
EXIT DO
ELSEIF YN$=CHR$(27) THEN
RUN "MAIN.BAS"
END IF
LOOP
REM ********************************************************************************
CLS
PI = 3.141592653589793#: PU = 180 / PI
INPUT "请输入数据文件名:(DXPC.DAT)"; FILEIN$
IF FILEIN$ = "" THEN
FILEIN$ = "DXPC.DAT"
END IF
OPEN FILEIN$ FOR INPUT AS #1
INPUT #1, N, M, H
DIM B(N), D(M), A(N - 1), X(M), Y(M)
INPUT #1, X1, Y1, X, Y
FOR I = 0 TO N
INPUT #1, B(I)
B(I) = DEG(B(I))
NEXT I
FOR I = 1 TO M
INPUT #1, D(I)
NEXT I
CLOSE #1
REM ********************************************************************************
A(0) = B(0)
FOR I = 1 TO N - 1
A(I) = A(I - 1) + B(I) + 180
IF A(I) > 360 THEN
A(I) = A(I) - 360
END IF
NEXT I
F0 = H / 3600 * SQR(N - 1): F1 = A(N - 1) - B(N)
V = -1 * F1 / (N - 1)
FOR I = 1 TO N - 1
A(I) = A(I) + V * I
IF A(I) > 360 THEN
A(I) = A(I) - 360
END IF
NEXT I

S = 0: X(0) = X1: Y(0) = Y1
FOR I = 1 TO M
S = S + D(I)
X(I) = X(I - 1) + D(I) * COS(A(I) / PU)
Y(I) = Y(I - 1) + D(I) * SIN(A(I) / PU)
NEXT I
F3 = X(M) - X: F4 = Y(M) - Y: F = ABS(SQR(F3 * F3 + F4 * F4))
D = 0
FOR I = 1 TO M
D = D + D(I)
X(I) = X(I) - F3 / S * D
Y(I) = Y(I) - F4 / S * D
NEXT I
REM ********************************************************************************
PRINT "方位角允许闭合差 F0=+/-"; XCHAR$(DMS(F0), 6)
IF ABS(F1) <= F0 THEN
PRINT "导线方位角闭合差 F1= "; XCHAR$(DMS(F1), 6); " OK!"
ELSE
PRINT "导线方位角闭合差 F1= "; XCHAR$(DMS(F1), 6); " OVER LIMIT!"
END IF
PRINT "相对闭合差:"
PRINT TAB(5); "F3="; F3, "F4="; F4, "F="; F, "K=1/"; S / F
PRINT "改正后方位角:"
FOR I = 0 TO N - 1
PRINT TAB(5); "A("; I; ")="; XCHAR$(DMS(A(I)), 6)
NEXT I
PRINT "改正后坐标:"
FOR I = 0 TO M
PRINT TAB(5); "X("; I; ")="; XCHAR$(X(I), 4), TAB(30); "Y("; I; ")="; XCHAR$(Y(I), 4)
NEXT I
PRINT TAB(5); "X("; M; ")="; XCHAR$(X(M), 4), TAB(30); "Y("; M; ")="; XCHAR$(Y(M), 4)

OPEN "DXPC.OUT" FOR OUTPUT AS #1
PRINT #1, " 导线平差"
PRINT #1, TAB(25); DATE$, TIME$
PRINT #1,
PRINT #1, "方位角允许闭合差 F0=+/-"; XCHAR$(DMS(F0), 6)
IF ABS(F1) <= F0 THEN
PRINT #1, "导线方位角闭合差 F1= "; XCHAR$(DMS(F1), 6); " OK!"
ELSE
PRINT #1, "导线方位角闭合差 F1= "; XCHAR$(DMS(F1), 6); " OVER LIMIT!"
END IF
PRINT #1, "相对闭合差:"
PRINT #1, TAB(5); "F3="; F3, "F4="; F4, "F="; F, "K=1/"; S / F
PRINT #1, "改正后方位角:"
FOR I = 0 TO N - 1
PRINT #1, TAB(5); "A("; I; ")="; XCHAR$(DMS(A(I)), 6)
NEXT I
PRINT #1, "改正后坐标:"
FOR I = 0 TO M
PRINT #1, TAB(5); "X("; I; ")="; XCHAR$(X(I), 4), TAB(30); "Y("; I; ")="; XCHAR$(Y(I), 4)
NEXT I
PRINT #1, TAB(5); "X("; M; ")="; XCHAR$(X(M), 4), TAB(30); "Y("; M; ")="; XCHAR$(Y(M), 4)
CLOSE #1
REM ********************************************************************************
PRINT
PRINT "详细数据资料业已备份到 JHFY.OUT。"
PRINT
PRINT "按 ESC键 返回主菜单..."
DO
LOOP UNTIL INKEY$ = CHR$(27)
RUN "MAIN.BAS"
END

REM 将度分秒转换成度
FUNCTION DEG (X)
D = INT(X)
M = INT((X - D) * 100)
S = INT((X - D - M / 100) * 1000000) / 100
DEG = D + M / 60 + S / 3600
END FUNCTION

REM 将度转换成度分秒
FUNCTION DMS (XX)
IF XX < 0 THEN
X = -XX
ELSE
X = XX
END IF
D = INT(X)
M = INT((X - D) * 60)
S = (X - D - M / 60) * 3600
IF XX >= 0 THEN
DMS = D + M / 100 + S / 10000
ELSE
DMS = -1 * (D + M / 100 + S / 10000)
END IF
END FUNCTION

REM 以字符串形式输出保留 N 位小数的 X
FUNCTION XCHAR$ (XX, N)
X = ABS(XX)
R = INT(X)
F = INT((X - R) * 10 ^ N + .5)
TEMP$ = MID$(STR$(F), 2)
WHILE LEN(TEMP$) < N
TEMP$ = "0" + TEMP$
WEND
TEMP$ = STR$(R) + "." + TEMP$
IF XX >= 0 THEN
XCHAR$ = TEMP$
ELSE
XCHAR$ = "-" + MID$(TEMP$, 2)
END IF
END FUNCTION

yuanzhijion

你用过吗

measuresoft

天啊,都是由本人的网站上贴到这的