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 + -
显示快捷键?