flood.bas
来自「设计暴雨洪水计算DOS程序」· BAS 代码 · 共 459 行
BAS
459 行
DECLARE SUB hs ()
DECLARE SUB INPUTDAT (a!())
DECLARE SUB hdxy2 ()
DECLARE SUB hdat2 ()
DECLARE SUB hbrow ()
DECLARE SUB prn ()
DECLARE SUB hdxy1 ()
DECLARE SUB hcalcu ()
DECLARE SUB hdat1 ()
DECLARE SUB tl ()
DECLARE SUB dxy2 ()
DECLARE SUB octant (z!(), d!(), xx!, yy!)
DECLARE SUB dat2 ()
DECLARE SUB LINPUT (a$, IT!, LT!, L!, H!, FC!, BC!, bcr!)
DECLARE SUB brow ()
DECLARE SUB prn ()
DECLARE SUB dxy1 ()
DECLARE SUB czxy (x1!, y1!, x2!, y2!, X!, y!)
DECLARE SUB calcu ()
DECLARE SUB dat1 ()
DECLARE SUB winaxi (x1!, y1!, x2!, y2!, WDK1!, WDK2!, HHK1!, HHK2!, HTIL$, ZTIL$, TTILEE$, XYC!, TC!, CONTION$)
DECLARE SUB RPRINT (a$, SIZE!, CLR!, AN!)
DECLARE SUB PCURVE (AVER!, CV!, CS!, mp!())
DECLARE FUNCTION KPGET! (CV!, CS!, p!)
COMMON SHARED /ASCII/ ASCII() AS STRING * 60
COMMON SHARED a(), p(), kkk, kk, cscv
COMMON SHARED /p3/ desp(), pcrv()
CLS : CLEAR , , 3072
DIM ASCII(1 TO 127) AS STRING * 60
CLS
DIM a(20), p(20), a$(20), aa$(20)
REM *************DON'T CHANGE ANY THING BELOW*******************************
DIM pcrv(1 TO 100, 1 TO 135), desp(1 TO 135), mp(20)
DIM P3P3$(135)
AV = FREEFILE
OPEN "PIII.LIB" FOR RANDOM AS #AV LEN = 544
IF LOF(AV) = 0 THEN
PRINT "FILE (PIII.LIB) NOT FOUND!!!"
CLOSE #AV
KILL "PIII.LIB"
END
ELSE
END IF
FOR I = 1 TO 135
FIELD #AV, (I - 1) * 4 AS X$, 4 AS P3P3$(I)
NEXT I
FOR I = 1 TO 100
GET #AV, I
FOR j = 1 TO 135
pcrv(I, j) = CVS(P3P3$(j))
NEXT j
NEXT I
CLOSE #AV
FOR I = 1 TO 135
READ desp(I)
NEXT I
FOR I = 1 TO 127: READ ASCII(I): NEXT I
DATA 0.0001,0.0002,0.0003,0.0004,0.0005,0.0006,0.0007,0.0008,0.0009
DATA 0.0010,0.0020,0.0030,0.0040,0.0050,0.0060,0.0070,0.0080,0.0090
DATA 0.0100,0.0200,0.0300,0.0400,0.0500,0.0600,0.0700,0.0800,0.0900,0.1000
DATA 0.1100,0.1200,0.1300,0.1400,0.1500,0.1600,0.1700,0.1800,0.1900,0.2000
DATA 0.2100,0.2200,0.2300,0.2400,0.2500,0.2600,0.2700,0.2800,0.2900,0.3000
DATA 0.3100,0.3200,0.3300,0.3400,0.3500,0.3600,0.3700,0.3800,0.3900,0.4000
DATA 0.4100,0.4200,0.4300,0.4400,0.4500,0.4600,0.4700,0.4800,0.4900,0.5000
DATA 0.5100,0.5200,0.5300,0.5400,0.5500,0.5600,0.5700,0.5800,0.5900,0.6000
DATA 0.6100,0.6200,0.6300,0.6400,0.6500,0.6600,0.6700,0.6800,0.6900,0.7000
DATA 0.7100,0.7200,0.7300,0.7400,0.7500,0.7600,0.7700,0.7800,0.7900,0.8000
DATA 0.8100,0.8200,0.8300,0.8400,0.8500,0.8600,0.8700,0.8800,0.8900,0.9000
DATA 0.9100,0.9200,0.9300,0.9400,0.9500,0.9600,0.9700,0.9800,0.9900
DATA 0.9910,0.9920,0.9930,0.9940,0.9950,0.9960,0.9970,0.9980,0.9990
DATA 0.9991,0.9992,0.9993,0.9994,0.9995,0.9996,0.9997,0.9998,0.9999
REM *************DON'T CHANGE ANY THING ABOVE********************************
kk = 1
DO
FOR I = 1 TO 20: a(I) = 0: p(I) = 0: NEXT
a$(1) = " 推 理 公 式 法 ": a$(2) = " 淮 上 法 "
a$(3) = " 退 出 "
aa$(1) = "推理公式法: 适用于山丘区集水面积 200 平方公里以下区域的洪峰及洪水过程的计算"
aa$(2) = "淮上法: 适用于山丘区集水面积 200-5000 平方公里区域的洪峰及洪水过程的计算 "
aa$(3) = "退出本程序!! "
SCREEN 0
COLOR 0, 0
CLS
COLOR 15, 4
LOCATE 2, 22: PRINT "河南省中小流域设计洪水计算 "
COLOR 15, 1
FOR I = 1 TO 3
LOCATE I + 3, 25: PRINT I; ". "; a$(I)
NEXT
COLOR 15, 4
DO
LOCATE kk + 3, 25: PRINT kk; ". "; a$(kk)
COLOR 10, 4
LOCATE 23, 1: PRINT " Enter: 选定. ←↑↓→: 移动" + SPACE$(50)
COLOR 15, 1
LOCATE 22, 1: PRINT aa$(kk) + SPACE$(80 - LEN(aa$(kk)))
a$ = ""
LINPUT a$, 1, 0, kk + 3, 46, 15, 4, bcr
SELECT CASE bcr
CASE 1072
COLOR 15, 1
LOCATE kk + 3, 25: PRINT kk; ". "; a$(kk)
kk = kk - 1: IF kk < 1 THEN kk = kk + 3
COLOR 15, 4
LOCATE kk + 3, 25: PRINT kk; ". "; a$(kk)
CASE 1080
COLOR 15, 1
LOCATE kk + 3, 25: PRINT kk; ". "; a$(kk)
kk = kk + 1: IF kk > 3 THEN kk = kk - 3
COLOR 15, 4
LOCATE kk + 3, 25: PRINT kk; ". "; a$(kk)
CASE 13
EXIT DO
CASE ELSE
END SELECT
LOOP
SELECT CASE kk
CASE 1
CALL tl
CASE 2
CALL hs
CASE 3
EXIT DO
END SELECT
LOOP
CLS
END
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA "BR10"
DATA "U2BU4U10BD10BD6BR10"
DATA "BU16BR2D6BR4U6BD16BR4"
DATA "BR2U16BR4D16BL6BU6R8BU4L8BD10BR10"
DATA "BU4F2R4E2U2H2L4H2U2E2R4F2BH2BH2D4D2D2D2D2D2D2BR6"
DATA "M+8,-16BL8D2R2U2L2BR8BD16U2L2D2R2BR2"
DATA "BR8BU4G4L2H2U4E2E2E2U2H2L2G2D2D2F2F4D2F2BR2"
DATA "BU12BR4M+2,-4BR4BD16"
DATA "BR6M-4,-4U8M+4,-4BD4BD4BD8BR4"
DATA "BR2E4U8H4BD16BR8"
DATA "BU4E8BL8F8BL4BU12D16BR6"
DATA "BU8R8BU8BL4D16BR6"
DATA "BR4E2U2L1D2R1BR4BD2"
DATA "BU8R8BR2BD8"
DATA "BR4BU2R2U2L2D2BD2BR6"
DATA "M+8,-16BD16BR2"
DATA "BR2R4E2U12H2L4G2D12F2BR8"
DATA "BR2R2R2BL2U14U2G2BD14BR8"
DATA "BR8L8U2E8U4H2L4G2BD4BD8BD2BR2BR4BR2BR2"
DATA "BU4BU2BU2BU4BU2E2R4F2D4G2L3R3F2D4G2L4H2BD2BR10"
DATA "BU4BR8L8U2M+6,-10D10D2D4BR4"
DATA "BU2F2R4E2U6H2L4G2U8R8BD8BD6BD2BR2"
DATA "BU6E2R4F2D4G2L4H2U12E2R4F2BR4BL2BL2BD14BR2"
DATA "BR2U6E6U4L6L2D2BD6BD8BR2BR8"
DATA "BR6L4H2U4E2R4E2U4H2L4G2D4F2R4F2D4G2BR4"
DATA "BU2F2R4E2U12H2L4G2D4F2R4E2BD10BR4BL2BL2BR2"
DATA "BU2BR2R2U2L2D2BU10R2U2L2D2BD10BD2BR8"
DATA "BR2E2U2L2D2R2BU10U2L2D2R2BD10BD2BR8BL2"
DATA "BU8BU8BR8M-8,+8M+8,+8BR2"
DATA "BU6R8BU4L8BF10"
DATA "M+8,-8M-8,-8BD8BD8BR10"
DATA "BR2BR2U2BU6E4U2H2L4G2D2BD6BD6BR2BR4BR4"
DATA "BR4BR2BR2BU2G2L4H2U12E2R4F2D10H2G2L2U6E2R2D6BD6BR4"
DATA "U12E4F4D12BU8L8BD8BR10"
DATA "U2U4U2U2U4U2R6F2D4G2L6R6F2D4G2L6BR10"
DATA "BU14BR8H2L4G2D12F2R4E2BF2"
DATA "U2U12U2R6F2D12G2L6BR10"
DATA "BU16BR8L8D8R6L6D8R8BR2"
DATA "U8R6L6U8R8BR2BD16"
DATA "BU14BR8H2L4G2D12F2R4E2U4L4BR6BD6"
DATA "U16BR8D16BU8L8BD8BR10"
DATA "BR4U16L2R2R2BD16L2L2BR4BR2BR2"
DATA "BU2F2R4E2U14BD14BD2BR4BL2"
DATA "U2U4U8U2BR8D2M-8,+8BE2M+6,+6D2BR4BL2"
DATA "BU16D16R8BR2"
DATA "U16D2M+4,+4M+4,-4U2D16BR2"
DATA "U16D2M+8,+8U10D16BR2"
DATA "BR2R4E2U12H2L4G2D12F2BR8"
DATA "U8U2U4U2R6F2D4G2L6BD8BR10"
DATA "BR2R4E2U12H2L4G2D12F2BM+2,-6M+4,+6BR4BL2"
DATA "U8U2U4U2R6F2D4G2L6R4M+4,+8BR2"
DATA "BU2F2R4E2U4H2L4H2U4E2R4F2BD4BD2BD2BD4BD2BR4BL2"
DATA "BU16R8L4D16BR6"
DATA "BU16D14F2R4E2U14BD16BR4BL2"
DATA "BU16D12F4E4U12BD16BR2"
DATA "BU16D12M+2,+4M+2,-6M+2,+6M+2,-4U12BD16BR8BL2BL2BL2"
DATA "U4M+8,-8U4BL8D4M+8,+8D4BR2"
DATA "BU16D4M+4,+4M+4,-4U4BM-4,+8D8BR6"
DATA "BU16R8D4M-8,+8D4R8BR2"
DATA "BR6L2U16R2BD16BR4"
DATA "BU16M+8,+16BR2"
DATA "BR2R2U16L2BD16BR8"
DATA "BU12M+4,-4M+4,+4BD12BR2"
DATA "BD2R8BU2BR2"
DATA "BU16BR2M+2,+4BD12BR8BL2"
DATA "BR4BR2BR2H2U2H2L2G2D2F2R2E2U6H2L4BD2BD4BD2BD2BR10"
DATA "BU8E2R4F2D6G2L4H2U14BD16BR10"
DATA "BR8BU2BU4BU2H2L4G2D6F2R4E2BD2BR2"
DATA "BR8BU8H2L4G2D6F2R4E2U14BD16BR2"
DATA "BU6R8U2H2L4G2D6F2R4E2BD2BR2"
DATA "BR2U14E2R2F2BD6BL2L6BD8BR12BL2"
DATA "BR8BU2G2L4H2U6E2R4F2D2D6D4G2L4H2BU4BR2BR4BR2BR2"
DATA "U16BD8E2R4F2D8BR4BL2"
DATA "BR2R4BL2U10L2BR2BU4U2BD2BD4BD10BR6"
DATA "BD4F2R2E2U14BU4U2BD2BD4BD10BR8BL2BL2"
DATA "U2U10U4BD10E6BG4F6D2BR4BL2"
DATA "BR2R4BL2U16L2BR6BR2BD16"
DATA "U10R2F2D8BU8E2R2D10BL2BR8BL2BL2"
DATA "BU10R2D10BU8E2R2F2D8BL2BR8BL2BL2"
DATA "BU2F2R4E2U6H2L4G2D6BD2BR10"
DATA "BD6U6U2U4U2E2R4F2D6G2L4H2BD2BR10"
DATA "BR8BU2G2L4H2U6E2R4F2D6D6D2BU6BR2"
DATA "BR2U8H2F2E2F4BD6BR4BL2"
DATA "BU2F2R4E2U2H2L2L2H2E2R6BD2BD2BD2BD2BD2BR2"
DATA "BU10R6BL2L2BU6D14F2R2E2BD2BR4BL2"
DATA "BU10D8F2R2E2U8BD8F2BL2BR8BL2BL2"
DATA "BU10D6F4E4U6BD10BR2"
DATA "BU10D8F2E2U2BD2F2E2U8BD10BL2BR8BL2BL2"
DATA "U2E8BL8F8D2BR2"
DATA "BU10D8F2R4E2U8BD4BD4D2D2G4L2L2BU6BR10"
DATA "BU10R8G8D2R8BR2"
DATA "BR6H2U4H2E2U4E2BD2BD4BD2BD2BD4BD2BR4"
DATA "BR4U6BU4U6BD6BD6BD4BR6"
DATA "BR2E2U4E2H2U4H2BD2BD4BD2BD2BD4BD2BR8"
DATA "BU6M+2,-4M+4,+4M+2,-4BD10BR4BL2"
DATA "U4M+4,-4M+4,+4D4L8BR10"
END
SUB czxy (x1, y1, x2, y2, X, y)
y = y1 + (y2 - y1) * (X - x1) / (x2 - x1)
END SUB
SUB LINPUT (a$, IT, LT, L, H, FC, BC, bcr)
IF LT <> 0 AND IT <= LT + 1 THEN PRINT "Illegal function call": EXIT SUB
bcr = 0
a$ = RTRIM$(LTRIM$(a$))
COLOR FC, BC
PS = INSTR(a$, ".")
IF LT = 0 AND PS <> 0 THEN
a$ = LEFT$(a$, PS - 1)
ELSEIF LT <> 0 AND PS = 0 THEN
PS = IT - LT
ELSE
END IF
IF LT = 0 THEN
A1$ = SPACE$(IT - LEN(a$)) + a$
A2$ = ""
LOCATE L, H: PRINT A1$;
ELSEIF LT < 0 THEN
A1$ = a$ + SPACE$(IT - LEN(a$))
A2$ = ""
LOCATE L, H: PRINT A1$;
ELSE
A1$ = SPACE$(IT - LT - 1 - LEN(LEFT$(a$, PS - 1))) + LEFT$(a$, PS - 1)
A2$ = MID$(a$, PS + 1) + SPACE$(LT - LEN(MID$(a$, PS + 1)))
LOCATE L, H: PRINT A1$ + "." + A2$;
END IF
LOCATE L, H, 1, 0, 7
IN1$ = "": IN2$ = ""
DO
DO
DO: IN$ = INKEY$: LOOP UNTIL IN$ <> ""
IF LEN(IN$) = 1 THEN
EXIT DO
ELSE
bcr = 1000 + ASC(MID$(IN$, 2, 1))
EXIT DO
END IF
LOOP
IF bcr > 1000 THEN
EXIT DO
ELSEIF IN$ = CHR$(13) THEN
bcr = 13
EXIT DO
ELSEIF IN$ = CHR$(9) THEN
bcr = 9
EXIT DO
ELSEIF IN$ = CHR$(10) OR IN$ = CHR$(14) OR IN$ = CHR$(25) THEN
bcr = ASC(IN$)
EXIT DO
ELSEIF IN$ = CHR$(27) THEN
IN1$ = "": IN2$ = "": PINT = 0: FIRST = 0
IF LT <= 0 THEN
LOCATE L, H: PRINT A1$;
ELSE
LOCATE L, H: PRINT A1$ + "." + A2$;
END IF
ELSEIF IN$ = CHR$(8) THEN
IF PINT = 1 THEN
IF LEN(IN2$) >= 1 THEN IN2$ = LEFT$(IN2$, LEN(IN2$) - 1)
LOCATE L, H + IT - LT + LEN(IN2$): PRINT " ";
LOCATE L, H + IT - LT + LEN(IN2$)
IF IN2$ = "" THEN
PINT = 0: FIRST = 0
ELSE
END IF
ELSE
IF LEN(IN1$) >= 1 THEN IN1$ = LEFT$(IN1$, LEN(IN1$) - 1)
LOCATE L, H + LEN(IN1$): PRINT " ";
LOCATE L, H + LEN(IN1$)
END IF
ELSEIF IN$ = "." AND LT >= 1 THEN
IF PINT = 0 THEN
PINT = 1
ELSEIF IN2$ = "" AND FIRST = 0 THEN
FIRST = 1
ELSE
SOUND 1500, 2
END IF
ELSE
IF LT < 1 THEN
IN1$ = IN1$ + IN$
ELSE
IF PINT = 0 THEN
IN1$ = IN1$ + IN$
ELSE
FIRST = 1
IN2$ = IN2$ + IN$
END IF
IF LEN(IN1$) = IT - LT - 1 AND PINT = 0 AND LT <> 0 THEN
PINT = 1
END IF
END IF
END IF
IF PINT = 1 AND LT >= 0 THEN
IF FIRST = 0 THEN
LOCATE L, H: PRINT SPACE$(IT - LT - 1 - LEN(IN1$)) + IN1$;
ELSE
LOCATE L, H: PRINT SPACE$(IT - LT - 1 - LEN(IN1$)) + IN1$ + "." + IN2$;
END IF
IF LEN(IN2$) >= LT THEN : bcr = 13: SOUND 1300, 3: EXIT DO
ELSE
LOCATE L, H, 1: PRINT IN1$;
IF LEN(IN1$) >= IT THEN bcr = 13: SOUND 1300, 3: EXIT DO
END IF
LOOP
IF IN1$ + IN2$ = "" THEN
ELSE
IF LT <= 0 THEN
a$ = IN1$
ELSE
a$ = IN1$ + "." + IN2$ + STRING$(LT - LEN(IN2$), 32)
END IF
END IF
IF LT < 0 THEN
LOCATE L, H: PRINT a$ + SPACE$(IT - LEN(a$));
ELSE
LOCATE L, H: PRINT SPACE$(IT - LEN(a$)) + a$;
END IF
LOCATE , , 0
END SUB
SUB RPRINT (a$, SIZE, CLR, AN)
SHARED ASCII() AS STRING * 60
SSIZE = INT(SIZE + .5)
CCLR = INT(CLR)
AAN = INT(AN)
L = LEN(a$)
FOPEN% = 0
FOR I = 1 TO L
CR = ASC(MID$(a$, I, 1))
IF CR > 127 THEN
IF FOPEN% = 0 THEN
FOPEN% = 1
AV = FREEFILE
OPEN "ASCII.LIB" FOR RANDOM AS #AV LEN = 60
FIELD #AV, 60 AS SA$
ELSE
END IF
GET #AV, CR
SSA$ = LTRIM$(RTRIM$(SA$))
ELSE
SSA$ = LTRIM$(RTRIM$(ASCII(CR)))
END IF
IF SSA$ <> "" THEN
DRAW "S" + STR$(SSIZE) + "C" + STR$(CCLR) + "TA" + STR$(AAN) + SSA$ + "BR2"
ELSE
END IF
NEXT I
IF FOPEN% <> 0 THEN CLOSE #AV
END SUB
SUB winaxi (x1, y1, x2, y2, WDK1, WDK2, HHK1, HHK2, HTIL$, ZTIL$, TTILEE$, XYC, TC, CONTION$)
xx = x2 - x1
yy = y2 - y1
WINDOW (x1 - WDK1 * xx, y1 - HHK1 * yy)-(x2 + WDK2 * xx, y2 + HHK2 * yy)
FOR XI = 0 TO 12
IF x2 / 12 ^ XI < 100000 THEN EXIT FOR
NEXT XI
XUNIT$ = ""
IF XI > 0 THEN XUNIT$ = STR$(12 ^ XI)
FOR yj = 0 TO 10
IF y2 / 10 ^ yj < 100000 THEN EXIT FOR
NEXT yj
ZUNIT$ = ""
IF yj > 0 THEN ZUNIT$ = STR$(10 ^ yj)
LINE (x1 - .01 * xx, y1 - .01 * yy)-(x2, y1 - .01 * yy), XYC
FOR I = 0 TO 12
LINE (x1 + I * xx / 12, y1 - .03 * yy)-(x1 + I * xx / 12, y1 - .01 * yy), XYC
NEXT I
LINE (x1 - .01 * xx, y1 - .01 * yy)-(x1 - .01 * xx, y2), XYC
FOR I = 0 TO 10
LINE (x1 - .03 * xx, y1 + I * yy / 10)-(x1 - .01 * xx, y1 + I * yy / 10), XYC
NEXT I
FOR I = 0 TO 12
PSET (x1 + I * xx / 12, y1 - HHK1 * yy), 0
RPRINT MID$(STR$((x1 + I * xx / 12) / 12 ^ XI), 2, 4), 2, TC, 90
NEXT I
FOR I = 0 TO 10
PSET (x1 - WDK1 * xx, y1 + I * yy / 10), 0
RPRINT MID$(STR$((y1 + I * yy / 10) / 10 ^ yj), 2, 5), 2, TC, 0
NEXT I
PSET (x1 + .2 * xx, y1 - .07 * yy), 0
RPRINT HTIL$ + XUNIT$, 2, TC, 0
PSET (x1 - .04 * xx, y1 + .2 * yy), 0
RPRINT ZTIL$ + ZUNIT$, 2, TC, 90
PSET (x1 + .3 * xx, y1 + 1.05 * yy), 0
RPRINT TTILEE$, 3, XYC, 0
IF UCASE$(CONTION$) = "Y" THEN
FOR I = 0 TO 12
LINE (x1 + I * xx / 12, y1)-(x1 + I * xx / 12, y1 + yy), TC + 1, , &HF0F0
NEXT I
FOR I = 0 TO 10
LINE (x1, y1 + I * yy / 10)-(x1 + xx, y1 + I * yy / 10), TC + 1, , &HF0F0
NEXT I
END IF
END SUB
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?