REM +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REM REM A TABU SEARCH PROCEDURE TO SIMULTANEOUSLY SOLVE AQUATIC HABITAT REM AND COMMODITY PRODUCTION GOALS REM REM PETE BETTINGER REM JANUARY 19, 1995 REM REM +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DIM RUNNUMBER AS STRING DECLARE SUB ALTINSOL (BUNIT) DECLARE SUB ALTNEIGH (BUNIT, BSILV, BSYS, HAUTE) DECLARE SUB ALTTABUR (BBB, FROMND, TND, ST, LINKS) DECLARE SUB ALTTABUU (UCOUNT) DECLARE SUB CHECKPATH (TVAR, UCOUNT, NODES) DECLARE SUB DIJKSTRA (BBB, UCOUNT, NODES, LINKS, POBLIT, GAP) DECLARE SUB ECA (TECA(), LINKS, UCOUNT) DECLARE SUB ECON (NETPV, UCOUNT, NODES, LINKS) DECLARE SUB FLIP (UCOUNT, LINKS) DECLARE SUB FLIPBACK (UCOUNT, LINKS) DECLARE SUB GROWTH (BBB, UCOUNT, LINKS) DECLARE SUB INITIAL (NODES, GAP, UCOUNT) DECLARE SUB MINGROWTH () DECLARE SUB NEIGHBOR (NETPV, BUNIT, UCOUNT, NODES, VOLUME(), BESTNPV) DECLARE SUB R1R4 (SACCOUNT(), SEDIMENT(), UCOUNT, NODES, LINKS) DECLARE SUB RANDOMSTART (UCOUNT, NODES) DECLARE SUB ROADCHANGE (FROMND, TND, PERIOD, ST) DECLARE SUB ROADUSE (UCOUNT, LINKS, UNIT, HSYS(), CUT(), PCUT(), PLUSMINUS) DECLARE SUB SAVEBEST (BBB, UCOUNT, LINKS, RUNNUMBER$) DECLARE SUB SHADOW (TEMPERATURE(), BBB) DECLARE SUB TABUTESTR (YY, EE, BB, LINKS) DECLARE SUB TABUTESTU (U, VV, UCOUNT) DECLARE SUB UNITCHOICE (TESTNPV, TPERIOD, BUNIT, BSILV, BSYS) DIM DATA1 AS STRING DATA1 = "C:\PETE\THESIS\MODULES\UNITS.PRN" DIM DATA2 AS STRING DATA2 = "C:\PETE\THESIS\MODULES\ROADS.PRN" DIM DATA13 AS STRING DATA13 = "C:\PETE\THESIS\MODULES\ROADTYPE.PRN" DIM DATA31 AS STRING DATA31 = "C:\PETE\THESIS\MODULES\OUTPUT.PRN" DIM DATA35 AS STRING DATA35 = "C:\PETE\THESIS\MODULES\DATA.PRN" DIM DATA47 AS STRING DATA47 = "C:\PETE\THESIS\MODULES\ROADUSE.PRN" DIM DATA71 AS STRING DATA71 = "C:\PETE\THESIS\MODULES\BADUNIT.PRN" DIM SACCOUNT(100, 3) AS SINGLE ' TOP 5 SEDIMENT-PROD RDS / PERIOD DIM CC AS STRING ' USED TO BREAK CODE DIM BBB AS SINGLE ' NUMBER OF ITERATIONS DIM NETPV AS SINGLE ' NET PRESENT VALUE TO NEIGHBOR DIM TESTNPV AS SINGLE ' CANDIDATE'S NPV DIM BESTNPV AS SINGLE ' BEST NPV DIM SEDIMENT(10) AS SINGLE ' SEDIMENT LEVELS FROM R1R4 DIM SEDGOAL AS SINGLE ' SEDIMENT GOAL DIM TEMPERATURE(10) AS SINGLE ' TEMPERATURE LEVELS FROM SHADOW DIM TEMPGOAL AS SINGLE ' TEMPERATURE GOAL DIM TECA(10) AS SINGLE ' ECA LEVELS FROM ECA DIM ITERATIONS AS SINGLE ' NUMBER OF ITERATIONS DIM STDD(10) AS SINGLE ' ROAD STANDARDS DIM CUT(10) AS SINGLE ' HARVEST VOLUME PER PERIOD DIM SYS(10) AS SINGLE ' LOGGING/SILV SYSTEM PER PERIOD DIM VOLUME(10) AS SINGLE ' TOTAL VOLUME PER PERIOD UCOUNT = 0 ' COUNTING UNITS OPEN DATA1 FOR INPUT AS #1 DO WHILE NOT EOF(1) INPUT #1, UNIT, AREA, HAZ, SYS, GEF, SLOPE, SPP, BA, AGE, VOL, DISTSTR, RIPAR, AVGK IF UNIT > UCOUNT THEN UCOUNT = UNIT LOOP CLOSE #1 ENDNODE = 0 LINKS = 0 OPEN DATA2 FOR INPUT AS #2 ' COUNTING NODES DO WHILE NOT EOF(2) INPUT #2, FROMNODE, TONODE, STD, LENGTH, GEFACTOR, DISTSTR, INWS, AVGK, RDSLOPE IF FROMNODE > ENDNODE THEN ENDNODE = FROMNODE IF TONODE > ENDNODE THEN ENDNODE = TONODE LINKS = LINKS + 1 LOOP CLOSE #2 ' VERIFIED 7/8/95 NODES = ENDNODE ' THE END NODE NUMBER DIM P1(NODES + 10, 3) AS SINGLE ' POINTER ARRAY DIM P2(NODES + 10, 2) AS SINGLE ' POINTER ARRAY TYPE TCOORD ' TYPE CODE FOR D(I,J) X AS SINGLE ' IN DIJKSTRA Y AS SINGLE Z AS SINGLE ' Z = DISTANCE OF PATH SED1 AS SINGLE ' SED = SEDIMENT CONTRIBUTION PER SED2 AS SINGLE ' PERIOD SED3 AS SINGLE SED4 AS SINGLE SED5 AS SINGLE SED6 AS SINGLE SED7 AS SINGLE SED8 AS SINGLE SED9 AS SINGLE SED10 AS SINGLE END TYPE TYPE TNEWDIST ' TYPE CODE FOR D(I,J) X AS SINGLE ' IN DIJKSTRA Y AS SINGLE Z AS SINGLE ' Z = DISTANCE OF PATH SED1 AS SINGLE ' SED = SEDIMENT CONTRIBUTION PER SED2 AS SINGLE ' PERIOD SED3 AS SINGLE SED4 AS SINGLE SED5 AS SINGLE SED6 AS SINGLE SED7 AS SINGLE SED8 AS SINGLE SED9 AS SINGLE SED10 AS SINGLE END TYPE TYPE TCOORT ' TYPE CODE FOR ROAD COSTS Q AS SINGLE ' PER LINK IN DIJKSTRA W AS SINGLE E AS SINGLE FIX1 AS SINGLE FIX2 AS SINGLE FIX3 AS SINGLE FIX4 AS SINGLE FIX5 AS SINGLE FIX6 AS SINGLE FIX7 AS SINGLE FIX8 AS SINGLE FIX9 AS SINGLE FIX10 AS SINGLE VAR1 AS SINGLE VAR2 AS SINGLE VAR3 AS SINGLE VAR4 AS SINGLE VAR5 AS SINGLE VAR6 AS SINGLE VAR7 AS SINGLE VAR8 AS SINGLE VAR9 AS SINGLE VAR10 AS SINGLE END TYPE TYPE TENTRYNODE ' TYPE CODE FOR ENTRY NODE FILE X AS SINGLE ' X = UNIT S AS SINGLE ' S = LOGGING SYSTEM E AS SINGLE ' E = ENTRY NODE END TYPE TYPE TMAINTCOST ' TYPE CODE FOR ROAD MAINTENANCE X AS SINGLE ' COSTS X = START NODE (MILL) Y AS SINGLE ' Y = TERMINUS (ENTRY NODE) Z AS SINGLE ' Z = PERIOD F AS SINGLE ' F = FIXED COST V AS SINGLE ' V = VARIABLE COST END TYPE TYPE TSEDIMENT ' TYPE CODE FOR SEDIMENT / PATH X AS SINGLE ' X = START NODE (MILL) Y AS SINGLE ' Y = TERMINUS (ENTRY NODE) I AS SINGLE ' I = PERIOD SED AS SINGLE ' SED = SEDIMENT PRODUCED / MBF END TYPE TYPE TTABUUNIT ' TYPE CODE FOR UNIT TABU STATE T AS SINGLE ' T = TABU STATE END TYPE ' EACH LINE = UNIT NUMBER TYPE TTABUROAD ' TYPE CODE FOR ROAD TABU STATE X AS SINGLE ' X = FROMNODE Y AS SINGLE ' Y = TONODE T AS SINGLE ' T = TABU STATE END TYPE ' EACH LINE = LINK IN ROADS.PRN TYPE THARVESTC ' TYPE CODE FOR HARVEST CHOICES SILV AS SINGLE ' SILV. SYSTEM C1 AS SINGLE ' CHOICE IN PERIOD 1 C2 AS SINGLE ' ETC... C3 AS SINGLE C4 AS SINGLE C5 AS SINGLE C6 AS SINGLE C7 AS SINGLE C8 AS SINGLE C9 AS SINGLE C10 AS SINGLE END TYPE ' EACH LINE = UNIT NUMBER TYPE TCUTVOL ' TYPE CODE FOR HARVEST VOLUMES SP AS SINGLE ' S = SPECIES C1 AS SINGLE ' C1 = VOLUME IN PERIOD 1 C2 AS SINGLE ' ETC... C3 AS SINGLE C4 AS SINGLE C5 AS SINGLE C6 AS SINGLE C7 AS SINGLE C8 AS SINGLE C9 AS SINGLE C10 AS SINGLE END TYPE ' EACH LINE = UNIT NUMBER TYPE TLINKS ' TYPE CODE FOR ROAD STANDARDS S1 AS SINGLE ' STANDARD IN PERIOD 1 S2 AS SINGLE ' ETC... S3 AS SINGLE S4 AS SINGLE S5 AS SINGLE S6 AS SINGLE S7 AS SINGLE S8 AS SINGLE S9 AS SINGLE S10 AS SINGLE END TYPE ' EACH LINE = LINK IN ROADS.PRN TYPE TUNITREVENUE ' TYPE CODE FOR UNIT REVENUES REV AS SINGLE ' UNIT REVENUE, TOTAL, 10 PERIODS END TYPE ' EACH LINE = UNIT NUMBER TYPE TUNITHAULCOST ' TYPE CODE FOR UNIT HAUL COSTS C AS SINGLE ' UNIT COST, TOTAL, 10 PERIODS END TYPE ' EACH LINE = UNIT NUMBER TYPE TBASAL ' TYPE CODE FOR BASAL AREA B1 AS SINGLE ' BA IN PERIOD 1 B2 AS SINGLE ' ETC... B3 AS SINGLE B4 AS SINGLE B5 AS SINGLE B6 AS SINGLE B7 AS SINGLE B8 AS SINGLE B9 AS SINGLE B10 AS SINGLE END TYPE ' EACH LINE = UNIT NUMBER TYPE THEIGHTS ' TYPE CODE FOR TREE HEIGHTS H1 AS SINGLE ' TREE HEIGHT IN PERIOD 1 H2 AS SINGLE ' ETC... H3 AS SINGLE H4 AS SINGLE H5 AS SINGLE H6 AS SINGLE H7 AS SINGLE H8 AS SINGLE H9 AS SINGLE H10 AS SINGLE END TYPE ' EACH LINE = UNIT NUMBER TYPE TGROWTH ' TYPE CODE FOR GROWTH FILES AGE AS SINGLE TPA AS SINGLE BA AS SINGLE BARATE AS SINGLE MBF AS SINGLE MBFRATE AS SINGLE HT AS SINGLE HTRATE AS SINGLE END TYPE ' EACH LINE = AGE (DECADE) TYPE TNOCUTAGE ' TYPE CODE FOR NO-CUT AGES A1 AS SINGLE ' A1 = AGE IN PERIOD 1 IF NO-CUT A2 AS SINGLE ' ETC... A3 AS SINGLE A4 AS SINGLE A5 AS SINGLE A6 AS SINGLE A7 AS SINGLE A8 AS SINGLE A9 AS SINGLE A10 AS SINGLE END TYPE ' EACH LINE = UNIT NUMBER TYPE TNOCUTVOL ' TYPE CODE FOR NO-CUT VOLUMES A1 AS SINGLE ' A1 = MBF IN PERIOD 1 IF NO-CUT A2 AS SINGLE ' ETC... A3 AS SINGLE A4 AS SINGLE A5 AS SINGLE A6 AS SINGLE A7 AS SINGLE A8 AS SINGLE A9 AS SINGLE A10 AS SINGLE END TYPE ' EACH LINE = UNIT NUMBER TYPE TINSOLUTION ' TYPE CODE FOR UNITS ALREADY PER AS SINGLE ' IN THE SOLUTION SILV AS SINGLE SYS AS SINGLE END TYPE ' EACH LINE = UNIT NUMBER TYPE TROADUSE ' TYPE CODE FOR ROAD USEAGE X AS SINGLE ' X = FROM-NODE Y AS SINGLE ' Y = TO-NODE U1 AS SINGLE ' U1 = USE IN PERIOD 1 U2 AS SINGLE ' ETC.. U3 AS SINGLE U4 AS SINGLE U5 AS SINGLE U6 AS SINGLE U7 AS SINGLE U8 AS SINGLE U9 AS SINGLE U10 AS SINGLE END TYPE ' EACH LINE = FROM- TO-NODE COMB. TYPE TSTREAMUNIT ' TYPE CODE FOR UNITS AT STREAMS U AS SINGLE END TYPE ' EACH LINE = UNIT NUMBER TYPE TBADUNIT ' TYPE CODE FOR NO-PATH UNITS U AS SINGLE END TYPE ' EACH LINE = UNIT NUMBER DIM TLINK AS TLINKS DIM TTABUR AS TTABUROAD DIM TUSE AS TROADUSE DIM TBADU AS TBADUNIT RUNNUMBER = "SCENARIO 1, #42, 2500 iterations" ITERATIONS = 2500 ' MAXIMUM NUMBER OF ITERATIONS SEDGOAL = 28.72 ' UPPER SEDIMENT LIMIT (T/MI2/YR) TEMPGOAL = 77 ' UPPER TEMPERATURE LIMIT (F) REM ******************************************************** REM REM MAIN TABU SEARCH ALGORITM REM REM ******************************************************** CLS COLOR 2, 0 PRINT PRINT "TABU SEARCH PROCEDURE - AQUATIC HABITAT GOALS AND LAND MANAGEMENT ACTIVITIES" PRINT COLOR 7, 0 RANDOMIZE TIMER OPEN DATA31 FOR OUTPUT AS #31 OPEN DATA35 FOR OUTPUT AS #35 BESTNPV = -99999999999# ' SET NPV = -9999999 BUNIT = 1 ' SET BEST UNIT = 1 (TEMPORARILY) BBB = 0 ' SET ITERATIONS = 0 'GOTO SHERIDAN 'GOTO GRRR2 'GOTO RER 'GOTO LINCOLN 'GOTO ALEXANDRIA PRINT #31, RUNNUMBER, DATE$, TIME$ PRINT #35, RUNNUMBER, DATE$, TIME$ CALL INITIAL(NODES, GAP, UCOUNT) ' CALL INITIAL SUBROUTINE PRINT #31, BBB; " INITIAL SUBROUTINE CALLED" CALL DIJKSTRA(BBB, UCOUNT, NODES, LINKS, POBLIT, GAP) PRINT #31, BBB; " DIJKSTRA - COMPUTING SHORTEST PATHS" CALL GROWTH(BBB, UCOUNT, LINKS) ' CALL GROWTH SUBROUTINE PRINT #31, BBB; " GROWTH SUBROUTINE CALLED" 'RER: CALL RANDOMSTART(UCOUNT, NODES) ' GENERATE RANDOM STARTING CONDITION PRINT #31, BBB; " RANDOMSTART SUBROUTINE CALLED" BBB = 1 CASPER: IF (BBB > 1) OR (BBB = 1 AND PGROWTH = 1) THEN PRINT #31, BBB; " DIJKSTRA START "; TIME$ CALL DIJKSTRA(BBB, UCOUNT, NODES, LINKS, POBLIT, GAP) PRINT #31, BBB; " DIJKSTRA END "; TIME$ END IF IF (BBB = 1 AND PGROWTH = 0) THEN CALL GROWTH(BBB, UCOUNT, LINKS) ' CALL GROWTH SUBROUTINE AGAIN PRINT #31, BBB; " GROWTH SUBROUTINE CALLED" PGROWTH = 1 END IF LINCOLN: NETPV = 0 CALL ECON(NETPV, UCOUNT, NODES, LINKS) ' CALL ECONOMICS SUBROUTINE PRINT #31, BBB; " ECONOMICS SUBROUTINE CALLED - NPV = "; NETPV IF BBB = 1 THEN BESTNPV = NETPV ALEXANDRIA: CALL NEIGHBOR(NETPV, BUNIT, UCOUNT, NODES, VOLUME(), BESTNPV) ' CALL NEIGHBORHOOD GENERATOR PRINT #31, BBB; " NEIGHBORHOOD SUBROUTINE CALLED" OCALA: CALL UNITCHOICE(TESTNPV, TPERIOD, BUNIT, BSILV, BSYS) ' CALL UNIT CHOICE SUBROUTINE PRINT #31, BBB; " UNITCHOICE SUBROUTINE CALLED - UNIT "; BUNIT; " CHOSEN FOR PERIOD "; TPERIOD IF BUNIT = -1 THEN ' IF NO UNITS CHOSEN PRINT " No Candidates to choose from" PRINT #31, " No Candidates to choose from" BUNIT = 0 ' UNSCHEDULE A UNIT GOTO ALEXANDRIA END IF 'RER: HAUTE = 0 TVAR = 0 CALL CHECKPATH(TVAR, UCOUNT, NODES) IF TVAR = 1 THEN PRINT #31, BBB; " CHECKPATH CALLED, PATH EXISTS FOR CANDIDATE" ELSE PRINT #31, BBB; " CHECKPATH CALLED, NO PATH EXISTS" END IF IF TVAR = 0 THEN ' NO PATH EXISTS HAUTE = 1 ' HAUTE IS A MARKER OPEN DATA71 FOR RANDOM AS #71 TBADU.U = 1 PUT #71, BUNIT, TBADU PRINT #31, BBB; " ADJUSTING BADUNIT.PRN FOR UNIT "; BUNIT CLOSE #71 CALL ALTNEIGH(BUNIT, BSILV, BSYS, HAUTE) ' ALTER THE NEIGHBORHOOD PRINT #31, BBB; " ALTNEIGH SUBROUTINE CALLED - UNIT NEIGHBORHOOD ALTERED" GOTO OCALA ' GOTO UNITCHOICE - SELECT ANOTHER UNIT END IF CALL MINGROWTH ' CALL MINI GROWTH SUBROUTINE PRINT #31, BBB; " MINGROWTH SUBROUTINE CALLED - GROWING THE CANDIDATE" CALL FLIP(UCOUNT, LINKS) ' CALL SUBROUTINE TO FLIP CANDIDATE ' INTO THE PERMANENT FILES PRINT #31, BBB; " FLIP SUBROUTINE CALLED - CANDIDATE IS FLIPPED INTO PERMANENT FILES" SHERIDAN: CALL R1R4(SACCOUNT(), SEDIMENT(), UCOUNT, NODES, LINKS) ' CALL R1R4 SEDIMENT MODULE PRINT #31, BBB; " R1R4 SUBROUTINE CALLED" FOR I = 1 TO 10 ' FOR EACH PERIOD IF SEDIMENT(I) > SEDGOAL THEN ' IF SEDIMENT GOAL VIOLATED PERIOD = I ' REMEMBER PERIOD TPERIOD = I PRINT #31, BBB; " SEDIMENT GOAL VIOLATED, PERIOD "; I PRINT PRINT USING " Iteration ####, Period ##, Sediment Goal Violated"; BBB; I P = RND ' PICK A RANDOM NUMBER IF P < .3333 THEN ' IF RND < .3333, SEND BACK UNIT WICHITA: CALL FLIPBACK(UCOUNT, LINKS) ' FLIP UNIT CHOICE BACK PRINT " Decided to Flip the Unit Back" PRINT #31, BBB; " FLIPBACK SUBROUTINE CALLED - CANDIDATE FLIPPED BACK" CALL ALTNEIGH(BUNIT, BSILV, BSYS, HAUTE) ' ALTER THE NEIGHBORHOOD PRINT #31, BBB; " ALTNEIGH SUBROUTINE CALLED - UNIT NEIGHBORHOOD ALTERED" GOTO OCALA ' GOTO UNITCHOICE - SELECT ANOTHER UNIT ELSE SUM = 0 IF P < .6667 THEN ' IF RND < .6667, OBLIT. A ROAD PRINT " Option: Obliterate a Road" PRINT #31, BBB; " Option: Road Obliteration" JOBLIT = 0 FOR J = (10 * I - 9) TO (10 * I) ' LOOKING IN SACCOUNT() PRINT " Looking for a road to obliterate" PRINT #31, BBB; " Looking for a road to obliterate" OPEN DATA47 FOR RANDOM AS #47 FOR K = 1 TO LINKS ' FOR ALL ROADS GET #47, K, TUSE 'PRINT USING "FROM NODE #####"; TUSE.X 'PRINT USING "TO NODE #####"; TUSE.Y 'PRINT TUSE.U1 'PRINT TUSE.U2 'PRINT TUSE.U3 'PRINT TUSE.U4 'PRINT TUSE.U5 'PRINT TUSE.U6 'PRINT TUSE.U7 'PRINT TUSE.U8 'PRINT TUSE.U9 'PRINT TUSE.U10 'PRINT 'CC = INPUT$(1) IF (TUSE.X = SACCOUNT(J, 1) AND TUSE.Y = SACCOUNT(J, 2)) OR (TUSE.X = SACCOUNT(J, 2) AND TUSE.Y = SACCOUNT(J, 1)) THEN SUM = TUSE.U1 + TUSE.U2 + TUSE.U3 + TUSE.U4 + TUSE.U5 + TUSE.U6 + TUSE.U7 + TUSE.U8 + TUSE.U9 + TUSE.U10 EXIT FOR END IF NEXT K CLOSE #47 IF SUM = 0 THEN ' IF ROAD NOT USED, POSSIBLY OBLITERATE PRINT " Located a Road to Obliterate" PRINT #31, BBB; " Located a Road to Obliterate" BB = 0 YY = SACCOUNT(J, 1) EE = SACCOUNT(J, 2) CALL TABUTESTR(YY, EE, BB, LINKS) ' CHECK TABU LIST PRINT #31, BBB; " TABUTESTR SUBROUTINE CALLED - CHECKING TABU LIST FOR ROAD OBLITERATION" IF BB = 0 THEN ' IF NOT TABU, THEN OBLITERATE PRINT " Road is not Tabu, so will obliterate" PRINT #31, BBB; " Road is not Tabu, so will obliterate" JOBLIT = 1 PRINT #31, BBB; " ROAD TO BE OBLITERATED, FROM NODE = "; YY; " TO NODE = "; EE PRINT USING " Obliterate Road, Period = ##, FROMNODE = ####, TONODE = ####"; I; YY; EE FROMND = SACCOUNT(J, 1) TND = SACCOUNT(J, 2) ST = 0 CALL ROADCHANGE(FROMND, TND, PERIOD, ST) PRINT #31, BBB; " ROADCHANGE SUBROUTINE CALLED - ROAD OBLITERATED DURING PERIOD "; PERIOD CALL ALTTABUR(BBB, FROMND, TND, ST, LINKS) ' ALTER TABU LIST PRINT #31, BBB; " ALTTABUR SUBROUTINE CALLED - TABU LIST FOR ROADS ALTERED" CALL FLIPBACK(UCOUNT, LINKS) ' FLIP UNIT BACK PRINT #31, BBB; " FLIPBACK SUBROUTINE CALLED - CANDIDATE UNIT FLIPPED BACK" POBLIT = I GOTO CASPER ' RE-RUN DIJKSTRA END IF END IF NEXT J IF JOBLIT = 0 THEN PRINT #31, BBB; " Can't find a road to obliterate" PRINT " Can't find a road to obliterate" GOTO KOBLIT END IF ELSE ' OTHERWISE, POSSIBLY CTI A ROAD KOBLIT: JOBLIT = 0 PRINT #31, BBB; " Option: Road CTI" PRINT " Option: Road CTI" FOR J = (10 * I - 9) TO (10 * I) ' LOOK IN SACCOUNT() PRINT " Looking for a road to CTI" PRINT #31, BBB; " Looking for a road to CTI" BB = 0 YY = SACCOUNT(J, 1) EE = SACCOUNT(J, 2) CALL TABUTESTR(YY, EE, BB, LINKS) ' CHECK TABU LIST PRINT #31, BBB; " TABUTESTR SUBROUTINE CALLED - CHECKING TABU LIST FOR ROAD OBLITERATION" IF BB = 0 THEN ' IF NOT TABU, THEN CTI UK = 0 OPEN DATA2 FOR INPUT AS #2 DO WHILE NOT EOF(2) UK = UK + 1 INPUT #2, FRND, TND, STD1, LENGTH, GEF, DISSTR, INWS, AVGK, RDSLOPE IF (FRND = YY AND TND = EE) OR (FRND = EE AND TND = YY) THEN OPEN DATA13 FOR RANDOM AS #13 GET #13, UK, TLINK ' GETTING ROAD STANDARDS STDD(1) = TLINK.S1 STDD(2) = TLINK.S2 STDD(3) = TLINK.S3 STDD(4) = TLINK.S4 STDD(5) = TLINK.S5 STDD(6) = TLINK.S6 STDD(7) = TLINK.S7 STDD(8) = TLINK.S8 STDD(9) = TLINK.S9 STDD(10) = TLINK.S10 CLOSE #13 GOTO BUMPOUT END IF LOOP BUMPOUT: CLOSE #2 IF STDD(PERIOD) <> 2 THEN GOTO LARAMIE ' IF STD NOT ROCK, GET ANOTHER ROAD ELSE JOBLIT = 1 GOTO JACKSON END IF END IF LARAMIE: NEXT J ' GET NEXT ROAD JACKSON: IF JOBLIT = 0 THEN PRINT #31, BBB; " CAN'T FIND A ROAD TO CTI, SO WILL FLIP UNIT BACK" PRINT " Can't locate a road to CTI, so will flip unit back" GOTO WICHITA ' FLIP UNIT BACK END IF FROMND = SACCOUNT(J, 1) ' OTHERWISE, CTI THE ROAD TND = SACCOUNT(J, 2) ST = 3 CALL ROADCHANGE(FROMND, TND, PERIOD, ST) PRINT #31, BBB; " ROADCHANGE SUBROUTINE CALLED - ROAD CTI'D DURING PERIOD "; PERIOD CALL ALTTABUR(BBB, FROMND, TND, ST, LINKS) PRINT #31, BBB; " ALTTABUR SUBROUTINE CALLED - TABU LIST FOR ROADS ALTERED" GOTO SHERIDAN END IF END IF END IF NEXT I ' FINISHED RIR4 EVALUATION PRINT #31, BBB; " R1R4 FINISHED SUCCESSFULLY, NO SEDIMENT GOALS VIOLATED" RER: CALL SHADOW(TEMPERATURE(), BBB) ' CALL SHADOW PRINT #31, BBB; " SHADOW SUBROUTINE CALLED" FOR I = 1 TO 10 ' FOR EACH PERIOD IF TEMPERATURE(I) > TEMPGOAL THEN ' IF TEMPERATURE GOAL VIOLATED PRINT #31, BBB; " TEMPERATURE GOAL VIOLATED IN PERIOD "; I PRINT PRINT " Temperature Goal Violated in Period "; I CALL FLIPBACK(UCOUNT, LINKS) ' FLIP UNIT CHOICE BACK PRINT #31, BBB; " FLIPBACK SUBROUTINE CALLED - FLIPPING CANDIDATE UNIT BACK" IF BBB = 1 THEN BUNIT = 0 PRINT #31, BBB; " TRYING TO LOWER STREAM TEMPERATURE DURING ITERATION 1" PRINT " Need to lower the temperature during iteration 1 - Infeasible starting solution" INFEASE = 1 GOTO MEMPHIS END IF CALL ALTNEIGH(BUNIT, BSILV, BSYS, HAUTE) ' ALTER THE NEIGHBORHOOD PRINT #31, BBB; " ALTNEIGH SUBROUTINE CALLED - ALTERING THE UNIT NEIGHBORHOOD" GOTO OCALA ' GOTO UNITCHOICE END IF NEXT I PRINT #31, BBB; " SHADOW FINISHED SUCCESSFULLY, NO TEMPERATURE GOALS VIOLATED" INFEASE = 0 MEMPHIS: IF INFEASE = 0 THEN CALL ECA(TECA(), LINKS, UCOUNT) ' CALL ECA PRINT #31, BBB; " ECA SUBROUTINE CALLED" END IF IF TESTNPV > BESTNPV AND INFEASE = 0 THEN ' TEST NPV > BEST NPV? BESTNPV = TESTNPV ' BEST NPV = TEST NPV CALL SAVEBEST(BBB, UCOUNT, LINKS, RUNNUMBER) ' SAVE THE BEST SOLUTION TO FILES PRINT #31, BBB; " BEST SOLUTION FOUND WITH NPV = "; BESTNPV END IF CALL ALTTABUU(UCOUNT) ' ALTER TABU STATE - UNITS PRINT #31, BBB; " CANDIDATE ACCEPTED, ALTERING THE TABU LIST FOR UNITS" PRINT " CANDIDATE ACCEPTED...." PRINT #31, BBB; " NPV IS "; TESTNPV CALL ALTINSOL(BUNIT) PRINT #31, BBB; " INSOL.PRN CHANGED" IF INFEASE = 0 THEN PRINT #35, BBB; TESTNPV PRINT #31, BBB; PRINT #35, BBB; FOR I = 1 TO 9 PRINT #31, SEDIMENT(I); PRINT #35, SEDIMENT(I); NEXT I PRINT #31, SEDIMENT(10) PRINT #35, SEDIMENT(10) PRINT #31, BBB; PRINT #35, BBB; FOR I = 1 TO 9 PRINT #31, TEMPERATURE(I); PRINT #35, TEMPERATURE(I); NEXT I PRINT #31, TEMPERATURE(10) PRINT #35, TEMPERATURE(10) PRINT #31, BBB; PRINT #35, BBB; FOR I = 1 TO 9 PRINT #31, TECA(I); PRINT #35, TECA(I); NEXT I PRINT #31, TECA(10) PRINT #35, TECA(10) PRINT #31, (BBB - 1); PRINT #35, (BBB - 1); FOR I = 1 TO 9 PRINT #31, VOLUME(I); PRINT #35, VOLUME(I); NEXT I PRINT #31, VOLUME(10) PRINT #35, VOLUME(10) END IF IF INFEASE = 1 THEN NETPV = TESTNPV GOTO ALEXANDRIA END IF PRINT COLOR 12, 0 PRINT USING "FINISHED ITERATION ####"; BBB COLOR 7, 0 PRINT #31, BBB; " FINISHED ITERATION " BBB = BBB + 1 ' MOVE FORWARD ONE ITERATION ' IF GOTTEN THIS FAR PRINT #31, "ITERATION "; BBB IF BBB < ITERATIONS THEN ' ALL ITERATIONS DONE? GOTO LINCOLN ' GOTO ECON END IF CLOSE #31 CLOSE #35 REM +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REM REM END - A TABU SEARCH PROCEDURE TO SIMULTANEOUSLY SOLVE AQUATIC REM HABITAT AND COMMODITY PRODUCTION GOALS REM REM +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ END SUB ALTINSOL (UNIT) REM ****************************************************** REM REM A SUBROUTINE TO ALTER THE "IN SOLUTION STATE" REM FOR UNIT CHOICES REM JANUARY 18, 1996 REM REM ****************************************************** DIM TINSOL AS TINSOLUTION DIM THARV AS THARVESTC DIM DATA10 AS STRING ' HARVEST CHOICES OVER 10 PERIODS DATA10 = "C:\PETE\THESIS\MODULES\HARVEST.PRN" DIM DATA45 AS STRING DATA45 = "C:\PETE\THESIS\MODULES\INSOL.PRN" DIM C(10) AS SINGLE OPEN DATA10 FOR RANDOM AS #10 GET #10, UNIT, THARV CLOSE #10 SILV = THARV.SILV C(1) = THARV.C1 C(2) = THARV.C2 C(3) = THARV.C3 C(4) = THARV.C4 C(5) = THARV.C5 C(6) = THARV.C6 C(7) = THARV.C7 C(8) = THARV.C8 C(9) = THARV.C9 C(10) = THARV.C10 FOR I = 1 TO 10 IF C(I) > 0 THEN SYS = C(I) EXIT FOR ELSE SYS = 0 END IF NEXT I IF I = 11 THEN I = 0 OPEN DATA45 FOR RANDOM AS #45 TINSOL.PER = I TINSOL.SILV = SILV TINSOL.SYS = SYS PUT #45, UNIT, TINSOL CLOSE #45 REM ****************************************************** REM REM END - ALTINSOL ' VERIFIED 1/18/96 REM REM ****************************************************** END SUB SUB ALTNEIGH (F, D, E, HT) ' F = BEST UNIT, D = BEST SILV. ' E = BEST SYSTEM REM ****************************************************** REM REM A SUBROUTINE TO ALTER THE NEIGHBORHOOD REM FOR REJECTED UNIT CHOICE CANDIDATES REM OCTOBER 12, 1995 REM REM ****************************************************** COLOR 2, 0 PRINT PRINT "ALTERING THE UNIT NEIGHBORHOOD" COLOR 7, 0 DIM DATA21 AS STRING DATA21 = "C:\PETE\THESIS\MODULES\UNITNPV.PRN" DIM DATA26 AS STRING DATA26 = "C:\PETE\THESIS\MODULES\DUMP.PRN" DIM C(10) AS SINGLE ' TEMPORARY ARRAY OPEN DATA21 FOR INPUT AS #21 OPEN DATA26 FOR OUTPUT AS #26 DO WHILE NOT EOF(21) INPUT #21, UNIT2, PER, SILV, C(0), C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8) IF F = UNIT2 AND D = SILV THEN C(E) = -99999999999# PRINT #26, UNIT2; PER; SILV; C(0); C(1); C(2); C(3); C(4); C(5); C(6); C(7); C(8) ELSEIF HT = 1 AND F = UNIT2 THEN FOR M = 0 TO 7 C(M) = -99999999999# NEXT M PRINT #26, UNIT2; PER; SILV; C(0); C(1); C(2); C(3); C(4); C(5); C(6); C(7); C(8) ELSE PRINT #26, UNIT2; PER; SILV; C(0); C(1); C(2); C(3); C(4); C(5); C(6); C(7); C(8) END IF LOOP CLOSE #21 CLOSE #26 OPEN DATA26 FOR INPUT AS #26 OPEN DATA21 FOR OUTPUT AS #21 DO WHILE NOT EOF(26) INPUT #26, UNIT2, PER, SILV, C(0), C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8) PRINT #21, UNIT2; PER; SILV; C(0); C(1); C(2); C(3); C(4); C(5); C(6); C(7); C(8) LOOP CLOSE #26 CLOSE #21 PRINT " Finished Altering the Unit Neighborhood" REM ****************************************************** REM REM END - A SUBROUTINE TO ALTER THE NEIGHBORHOOD REM FOR REJECTED CANDIDATES REM REM ****************************************************** END SUB SUB ALTTABUR (B, FROMND, TND, CSTD, LINKS) REM ************************************************** REM REM ALTERING THE TABU FILE FOR ROADS REM OCTOBER 25, 1995 REM REM ************************************************** COLOR 2, 0 PRINT PRINT "ALTERING THE TABU ARRAY FOR ROADS" COLOR 7, 0 DIM TTABUR AS TTABUROAD DIM DATA28 AS STRING DATA28 = "C:\PETE\THESIS\MODULES\TABUROAD.PRN" OPEN DATA28 FOR RANDOM AS #28 ' OPEN TABUROAD.PRN FOR I = 1 TO LINKS GET #28, I, TTABUR IF TTABUR.T > 0 THEN TTABUR.T = TTABUR.T - 1 ' IF TABU, REDUCE STATE IF TTABUR.X = FROMND AND TTABUR.Y = TND THEN TTABUR.T = 20 END IF PUT #28, I, TTABUR NEXT I CLOSE #28 ' CLOSE TABUROAD.PRN PRINT " Finished Altering the Tabu Array for Roads" REM ************************************************** REM REM END - ALTERING THE TABU FILE FOR ROADS REM REM ************************************************** END SUB SUB ALTTABUU (UCOUNT) REM ************************************************** REM REM ALTERING THE TABU FILE FOR UNITS REM OCTOBER 25, 1995 REM REM ************************************************** COLOR 2, 0 PRINT PRINT "ALTERING THE TABU ARRAY FOR UNITS" COLOR 7, 0 DIM TTABUU AS TTABUUNIT DIM DATA22 AS STRING DATA22 = "C:\PETE\THESIS\MODULES\CANDIDAT.PRN" DIM DATA27 AS STRING DATA27 = "C:\PETE\THESIS\MODULES\TABUUNIT.PRN" OPEN DATA22 FOR INPUT AS #22 ' OPEN CANDIDAT.PRN INPUT #22, UNIT, SILV ' GET UNIT, SILV. SYSTEM CLOSE #22 ' CLOSE CANDIDAT.PRN OPEN DATA27 FOR RANDOM AS #27 ' OPEN TABUUNIT.PRN FOR I = 2 TO UCOUNT GET #27, I, TTABUU ' INPUT UNIT, TABU STATE IF TTABUU.T > 0 THEN TTABUU.T = TTABUU.T - 1 ' IF TABU, REDUCE STATE IF UNIT = I THEN TTABUU.T = 125 ' IF CANDIDATE, STATE = 125 PUT #27, I, TTABUU NEXT I CLOSE #27 ' CLOSE TABUUNIT.PRN PRINT " Finished Altering the Tabu Array for Units" REM ************************************************** REM REM END - ALTERING THE TABU FILE FOR UNITS REM REM ************************************************** END SUB SUB CHECKPATH (TEMPVAR, UCOUNT, NODES) ' TEMPVAR = TEMPORARY VARIABLE, ' UCOUNT = UNITS, NODES = ROADS REM **************************************************************** REM REM CHECKING CANDIDATE TO SEE IF PATHS EXIST OVER THE REM ENTIRE PLANNING HORIZON FOR THE MANAGEMENT REGIME REM OCTOBER 24, 1995 REM PETE BETTINGER REM REM **************************************************************** COLOR 2, 0 PRINT PRINT "CHECKING THE PATHS FOR THE CANDIDATE" COLOR 7, 0 DIM TENTRY AS TENTRYNODE DIM TMNTCOST AS TMAINTCOST DIM DATA22 AS STRING DATA22 = "C:\PETE\THESIS\MODULES\CANDIDAT.PRN" DIM DATA40 AS STRING DATA40 = "C:\PETE\THESIS\MODULES\MNTCOST.PRN" DIM DATA42 AS STRING DATA42 = "C:\PETE\THESIS\MODULES\ENTRYRND.PRN" DIM CC AS STRING DIM C(10) AS SINGLE ' TEMPORARY ARRAY TESS: TEMPVAR = 1 ' SET TEMP VARIABLE SO THAT PATHS EXIST OPEN DATA22 FOR INPUT AS #22 ' OPEN CANDIDAT.PRN INPUT #22, UNIT1, SILV ' GET CANDIDATE'S UNIT NUMBER IF SILV = 0 THEN GOTO TAYLOR 'INPUT "UNIT "; UNIT1 'C = 2 IF UNIT1 = 0 THEN PRINT " No Candidate Unit in CANDIDAT.prn" END END IF FOR I = 1 TO 10 ' FOR EACH PERIOD INPUT #22, C IF C > 0 THEN ' IF A HARVEST IS TO OCCUR W = (((C - 1) * UCOUNT) + UNIT1) OPEN DATA42 FOR RANDOM AS #42 ' OPEN ENTRY.prn GET #42, W, TENTRY ENNODE = TENTRY.E CLOSE #42 W = (((I - 1) * NODES) + ENNODE) OPEN DATA40 FOR RANDOM AS #40 ' OPEN MNTCOST.PRN GET #40, W, TMNTCOST VARIAC = TMNTCOST.V CLOSE #40 IF VARIAC > 0 AND VARIAC < 99999 THEN GOTO LEON ELSE TEMPVAR = 0 ' NO PATH EXISTS IF VARIABLE COST = 0 GOTO TAYLOR END IF END IF LEON: ' GOING TO NEXT PERIOD NEXT I ' GOTO NEXT PERIOD TAYLOR: ' EXITING THE PROGRAM EARLY, SINCE ' WE DETERMINED THAT A PATH DOES NOT ' EXIST SOMEWHERE CLOSE #22 'PRINT USING "UNIT ##### ENTRY NODE ##### V COST ####.###"; UNIT1; ENNODE; VARIAC 'PRINT TEMPVAR 'CC = INPUT$(1) 'GOTO TESS PRINT " Finished Checking the Paths for the Candidate" REM **************************************************************** REM REM END - CHECKPATH ' VERIFIED 1/16/96 REM REM **************************************************************** END SUB SUB DIJKSTRA (B, UCOUNT, NODES, LINKS, POBLIT, GAP) REM +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REM REM Dijkstra's shortest path algorithm REM January 16, 1996 REM REM PETE BETTINGER REM REM This algorithm finds paths through a network which possess REM optimal properties. REM REM Smith, D.K. 1982. Network Optimisation Practice, A Computational REM Guide. Ellis Horwood Ltd., Chichester, West Sussex, England. REM 237 p. REM REM +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REM COMMENTS: REM 1. FINISHED CODE FOR START-TERMINUS APPLICATION REM (VERIFIED 6/29/95) REM 2. FINISHED CODE FOR GENERATING PATHS FROM ALL NODES REM TO START NODE (VERIFIED 7/6/95) REM 3. Verified Code with the John O'Leary Problem (7/6/95) REM 4. FINISHED CODE FOR READING DATA FROM A FILE, AND FOR REM OUTPUTTING PATHS TO A FILE REM 5. FINISHED CODE TO GENERATE PATHS FOR 1O PERIODS, USING REM ROADTYPE.prn REM +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DIM TPOINT AS TCOORD DIM TCOST AS TCOORT DIM TMNTCOST AS TMAINTCOST DIM TSED AS TSEDIMENT DIM TLINK AS TLINKS DIM TNEW AS TNEWDIST DIM TUSE AS TROADUSE COLOR 2, 0 PRINT PRINT "DIJKSTRA'S SHORTEST PATH ALGORITHM" COLOR 7, 0 DIM DATA2 AS STRING DATA2 = "C:\PETE\THESIS\MODULES\ROADS.PRN" DIM DATA4 AS STRING DATA4 = "C:\PETE\THESIS\MODULES\PATHS.PRN" DIM DATA13 AS STRING DATA13 = "C:\PETE\THESIS\MODULES\ROADTYPE.PRN" DIM DATA36 AS STRING DATA36 = "C:\PETE\THESIS\MODULES\NEWDIST.PRN" DIM DATA40 AS STRING DATA40 = "C:\PETE\THESIS\MODULES\MNTCOST.PRN" DIM DATA41 AS STRING DATA41 = "C:\PETE\THESIS\MODULES\LINKCOST.PRN" DIM DATA43 AS STRING DATA43 = "C:\PETE\THESIS\MODULES\SEDRND.PRN" DIM DATA46 AS STRING DATA46 = "C:\PETE\THESIS\MODULES\TEMPPATH.PRN" DIM DATA47 AS STRING DATA47 = "C:\PETE\THESIS\MODULES\ROADUSE.PRN" DIM CC AS STRING DIM ENDNODE AS SINGLE ' END NODE DIM COUNT AS SINGLE ' NUMBER OF ROADS DIM FROMNODE AS SINGLE ' FROM NODE DIM TONODE AS SINGLE ' TO NODE DIM STD(10) AS SINGLE ' ROAD STANDARD DIM D1 AS SINGLE ' ROAD LENGTH DIM LENGTH AS SINGLE ' ROAD LENGTH DIM GEFACTOR AS SINGLE ' GEOLOGIC EROSION FACTOR DIM START AS SINGLE ' STARTING NODE NUMBER DIM TERMINUS AS SINGLE ' THE TERMINUS NODE NUMBER DIM T0 AS SINGLE ' WORKING VARIABLES T0=ONE-WAY ' v. TWO-WAY (NOT USED HERE) DIM T1 AS SINGLE ' USED IN STEP 1, TEMPORARY VARIABLE DIM T2 AS SINGLE ' USED IN STEP 1, TEMPORARY VARIABLE DIM T3 AS SINGLE ' USED IN STEP 3, TEMPORARY VARIABLE DIM T4 AS SINGLE DIM T5 AS SINGLE ' T5 = MAXIMUM NUMBER OF NODES (NOT USED HERE) DIM T6 AS SINGLE DIM T7 AS SINGLE ' T7 = DISTANCE (NOT USED HERE) DIM T8 AS SINGLE ' USED IN STEP 3 = TEMPORARY VARIABLE DIM R(NODES) AS SINGLE ' PREDECESSOR NODE DIM O(NODES) AS SINGLE ' ORDERED PATH DIM L(NODES) AS SINGLE ' THE VALUE OF THE LABEL DIM Q(NODES) AS SINGLE ' 0 = TEMP LABEL; 1 = PERMANENT LABEL DIM S(NODES) AS SINGLE ' SEDIMENT ROUTE DIM F(NODES) AS SINGLE ' FIXED COSTS DIM V(NODES) AS SINGLE ' VARIABLE COSTS DIM SEDFACTOR AS SINGLE SEDFACTOR = .0000064 DIM VTIFACTOR(3) AS SINGLE VTIFACTOR(2) = 1 VTIFACTOR(3) = .4 DIM STD1(10) AS SINGLE 'PRINT NODES 'CC = INPUT$(1) START = 0 ' STARTING NODE NUMBER TERMINUS = NODES ' THE TERMINUS NODE NUMBER LCOUNT = LINKS * 2 IF (B > 1) AND (B MOD 3350 = 0) THEN OPEN DATA2 FOR INPUT AS #2 OPEN DATA47 FOR RANDOM AS #47 ' OPEN ROADUSE.PRN FOR G = 1 TO LINKS INPUT #2, FROMNODE, TONODE, STD, LENGTH, GEF, DISTSTR, INWS, AVGK, RDSLOPE TUSE.X = FROMNODE TUSE.Y = TONODE TUSE.U1 = 0 TUSE.U2 = 0 TUSE.U3 = 0 TUSE.U4 = 0 TUSE.U5 = 0 TUSE.U6 = 0 TUSE.U7 = 0 TUSE.U8 = 0 TUSE.U9 = 0 TUSE.U10 = 0 PUT #47, G, TUSE NEXT G CLOSE #2 CLOSE #47 END IF REM ******************************************************************* REM REM START DIJKSTRA'S SHORTHEST PATH ALGORITHM REM REM ******************************************************************* IF POBLIT > 0 THEN OPEN DATA4 FOR INPUT AS #4 OPEN DATA46 FOR OUTPUT AS #46 DO WHILE NOT EOF(4) INPUT #4, START, TERMINUS, Z, SED, NUMNODES, LENGTH PRINT #46, START; TERMINUS; Z; SED; NUMNODES; LENGTH; FOR I = 1 TO NUMNODES INPUT #4, NODE PRINT #46, NODE; NEXT I PRINT #46, LOOP CLOSE #4 CLOSE #46 ELSE OPEN DATA46 FOR OUTPUT AS #46 PRINT #46, 0; 0 CLOSE #46 END IF LINKS = 0 OPEN DATA2 FOR INPUT AS #2 ' OPEN ROADS.prn DO WHILE NOT EOF(2) ' FOR ALL LINKS LINKS = LINKS + 1 INPUT #2, FROMNODE, TONODE, STD, LENGTH, GEFACTOR, DISTSTR, INWS, AVGK, RDSLOPE OPEN DATA13 FOR RANDOM AS #13 ' OPEN ROADTYPE.prn GET #13, LINKS, TLINK CLOSE #13 OPEN DATA36 FOR RANDOM AS #36 FOR V = ((FROMNODE * GAP) + 1) TO ((FROMNODE * GAP) + GAP) GET #36, V, TNEW IF TNEW.X = FROMNODE AND TNEW.Y = TONODE THEN TNEW.SED1 = LENGTH * SEDFACTOR * VTIFACTOR(TLINK.S1) TNEW.SED2 = LENGTH * SEDFACTOR * VTIFACTOR(TLINK.S2) TNEW.SED3 = LENGTH * SEDFACTOR * VTIFACTOR(TLINK.S3) TNEW.SED4 = LENGTH * SEDFACTOR * VTIFACTOR(TLINK.S4) TNEW.SED5 = LENGTH * SEDFACTOR * VTIFACTOR(TLINK.S5) TNEW.SED6 = LENGTH * SEDFACTOR * VTIFACTOR(TLINK.S6) TNEW.SED7 = LENGTH * SEDFACTOR * VTIFACTOR(TLINK.S7) TNEW.SED8 = LENGTH * SEDFACTOR * VTIFACTOR(TLINK.S8) TNEW.SED9 = LENGTH * SEDFACTOR * VTIFACTOR(TLINK.S9) TNEW.SED10 = LENGTH * SEDFACTOR * VTIFACTOR(TLINK.S10) PUT #36, V, TNEW EXIT FOR END IF NEXT V CLOSE #36 STD(1) = TLINK.S1 STD(2) = TLINK.S2 STD(3) = TLINK.S3 STD(4) = TLINK.S4 STD(5) = TLINK.S5 STD(6) = TLINK.S6 STD(7) = TLINK.S7 STD(8) = TLINK.S8 STD(9) = TLINK.S9 STD(10) = TLINK.S10 OPEN DATA41 FOR RANDOM AS #41 FOR V = ((FROMNODE * GAP) + 1) TO ((FROMNODE * GAP) + GAP) GET #41, V, TCOST IF TCOST.Q = FROMNODE AND TCOST.W = TONODE THEN IF STD(1) = 2 OR STD(1) = 3 THEN TCOST.FIX1 = (LENGTH / 5280) * 1385 IF STD(2) = 2 OR STD(2) = 3 THEN TCOST.FIX2 = (LENGTH / 5280) * 1385 IF STD(3) = 2 OR STD(3) = 3 THEN TCOST.FIX3 = (LENGTH / 5280) * 1385 IF STD(4) = 2 OR STD(4) = 3 THEN TCOST.FIX4 = (LENGTH / 5280) * 1385 IF STD(5) = 2 OR STD(5) = 3 THEN TCOST.FIX5 = (LENGTH / 5280) * 1385 IF STD(6) = 2 OR STD(6) = 3 THEN TCOST.FIX6 = (LENGTH / 5280) * 1385 IF STD(7) = 2 OR STD(7) = 3 THEN TCOST.FIX7 = (LENGTH / 5280) * 1385 IF STD(8) = 2 OR STD(8) = 3 THEN TCOST.FIX8 = (LENGTH / 5280) * 1385 IF STD(9) = 2 OR STD(9) = 3 THEN TCOST.FIX9 = (LENGTH / 5280) * 1385 IF STD(10) = 2 OR STD(10) = 3 THEN TCOST.FIX10 = (LENGTH / 5280) * 1385 IF STD(1) = 2 OR STD(1) = 3 THEN TCOST.VAR1 = (LENGTH / 5280) * 1.22 IF STD(2) = 2 OR STD(2) = 3 THEN TCOST.VAR2 = (LENGTH / 5280) * 1.22 IF STD(3) = 2 OR STD(3) = 3 THEN TCOST.VAR3 = (LENGTH / 5280) * 1.22 IF STD(4) = 2 OR STD(4) = 3 THEN TCOST.VAR4 = (LENGTH / 5280) * 1.22 IF STD(5) = 2 OR STD(5) = 3 THEN TCOST.VAR5 = (LENGTH / 5280) * 1.22 IF STD(6) = 2 OR STD(6) = 3 THEN TCOST.VAR6 = (LENGTH / 5280) * 1.22 IF STD(7) = 2 OR STD(7) = 3 THEN TCOST.VAR7 = (LENGTH / 5280) * 1.22 IF STD(8) = 2 OR STD(8) = 3 THEN TCOST.VAR8 = (LENGTH / 5280) * 1.22 IF STD(9) = 2 OR STD(9) = 3 THEN TCOST.VAR9 = (LENGTH / 5280) * 1.22 IF STD(10) = 2 OR STD(10) = 3 THEN TCOST.VAR10 = (LENGTH / 5280) * 1.22 IF STD(1) = 1 THEN TCOST.VAR1 = (LENGTH / 5280) * .98 IF STD(2) = 1 THEN TCOST.VAR2 = (LENGTH / 5280) * .98 IF STD(3) = 1 THEN TCOST.VAR3 = (LENGTH / 5280) * .98 IF STD(4) = 1 THEN TCOST.VAR4 = (LENGTH / 5280) * .98 IF STD(5) = 1 THEN TCOST.VAR5 = (LENGTH / 5280) * .98 IF STD(6) = 1 THEN TCOST.VAR6 = (LENGTH / 5280) * .98 IF STD(7) = 1 THEN TCOST.VAR7 = (LENGTH / 5280) * .98 IF STD(8) = 1 THEN TCOST.VAR8 = (LENGTH / 5280) * .98 IF STD(9) = 1 THEN TCOST.VAR9 = (LENGTH / 5280) * .98 IF STD(10) = 1 THEN TCOST.VAR10 = (LENGTH / 5280) * .98 PUT #41, V, TCOST EXIT FOR END IF NEXT V CLOSE #41 OPEN DATA36 FOR RANDOM AS #36 FOR V = ((TONODE * GAP) + 1) TO ((TONODE * GAP) + GAP) GET #36, V, TNEW IF TNEW.X = TONODE AND TNEW.Y = FROMNODE THEN TNEW.SED1 = LENGTH * SEDFACTOR * VTIFACTOR(STD(1)) TNEW.SED2 = LENGTH * SEDFACTOR * VTIFACTOR(STD(2)) TNEW.SED3 = LENGTH * SEDFACTOR * VTIFACTOR(STD(3)) TNEW.SED4 = LENGTH * SEDFACTOR * VTIFACTOR(STD(4)) TNEW.SED5 = LENGTH * SEDFACTOR * VTIFACTOR(STD(5)) TNEW.SED6 = LENGTH * SEDFACTOR * VTIFACTOR(STD(6)) TNEW.SED7 = LENGTH * SEDFACTOR * VTIFACTOR(STD(7)) TNEW.SED8 = LENGTH * SEDFACTOR * VTIFACTOR(STD(8)) TNEW.SED9 = LENGTH * SEDFACTOR * VTIFACTOR(STD(9)) TNEW.SED10 = LENGTH * SEDFACTOR * VTIFACTOR(STD(10)) PUT #36, V, TNEW EXIT FOR END IF NEXT V CLOSE #36 OPEN DATA41 FOR RANDOM AS #41 FOR V = ((TONODE * GAP) + 1) TO ((TONODE * GAP) + GAP) GET #41, V, TCOST IF TCOST.Q = TONODE AND TCOST.W = FROMNODE THEN IF STD(1) = 2 OR STD(1) = 3 THEN TCOST.FIX1 = (LENGTH / 5280) * 1385 IF STD(2) = 2 OR STD(2) = 3 THEN TCOST.FIX2 = (LENGTH / 5280) * 1385 IF STD(3) = 2 OR STD(3) = 3 THEN TCOST.FIX3 = (LENGTH / 5280) * 1385 IF STD(4) = 2 OR STD(4) = 3 THEN TCOST.FIX4 = (LENGTH / 5280) * 1385 IF STD(5) = 2 OR STD(5) = 3 THEN TCOST.FIX5 = (LENGTH / 5280) * 1385 IF STD(6) = 2 OR STD(6) = 3 THEN TCOST.FIX6 = (LENGTH / 5280) * 1385 IF STD(7) = 2 OR STD(7) = 3 THEN TCOST.FIX7 = (LENGTH / 5280) * 1385 IF STD(8) = 2 OR STD(8) = 3 THEN TCOST.FIX8 = (LENGTH / 5280) * 1385 IF STD(9) = 2 OR STD(9) = 3 THEN TCOST.FIX9 = (LENGTH / 5280) * 1385 IF STD(10) = 2 OR STD(10) = 3 THEN TCOST.FIX10 = (LENGTH / 5280) * 1385 IF STD(1) = 2 OR STD(1) = 3 THEN TCOST.VAR1 = (LENGTH / 5280) * 1.22 IF STD(2) = 2 OR STD(2) = 3 THEN TCOST.VAR2 = (LENGTH / 5280) * 1.22 IF STD(3) = 2 OR STD(3) = 3 THEN TCOST.VAR3 = (LENGTH / 5280) * 1.22 IF STD(4) = 2 OR STD(4) = 3 THEN TCOST.VAR4 = (LENGTH / 5280) * 1.22 IF STD(5) = 2 OR STD(5) = 3 THEN TCOST.VAR5 = (LENGTH / 5280) * 1.22 IF STD(6) = 2 OR STD(6) = 3 THEN TCOST.VAR6 = (LENGTH / 5280) * 1.22 IF STD(7) = 2 OR STD(7) = 3 THEN TCOST.VAR7 = (LENGTH / 5280) * 1.22 IF STD(8) = 2 OR STD(8) = 3 THEN TCOST.VAR8 = (LENGTH / 5280) * 1.22 IF STD(9) = 2 OR STD(9) = 3 THEN TCOST.VAR9 = (LENGTH / 5280) * 1.22 IF STD(10) = 2 OR STD(10) = 3 THEN TCOST.VAR10 = (LENGTH / 5280) * 1.22 IF STD(1) = 1 THEN TCOST.VAR1 = (LENGTH / 5280) * .98 IF STD(2) = 1 THEN TCOST.VAR2 = (LENGTH / 5280) * .98 IF STD(3) = 1 THEN TCOST.VAR3 = (LENGTH / 5280) * .98 IF STD(4) = 1 THEN TCOST.VAR4 = (LENGTH / 5280) * .98 IF STD(5) = 1 THEN TCOST.VAR5 = (LENGTH / 5280) * .98 IF STD(6) = 1 THEN TCOST.VAR6 = (LENGTH / 5280) * .98 IF STD(7) = 1 THEN TCOST.VAR7 = (LENGTH / 5280) * .98 IF STD(8) = 1 THEN TCOST.VAR8 = (LENGTH / 5280) * .98 IF STD(9) = 1 THEN TCOST.VAR9 = (LENGTH / 5280) * .98 IF STD(10) = 1 THEN TCOST.VAR10 = (LENGTH / 5280) * .98 PUT #41, V, TCOST EXIT FOR END IF NEXT V CLOSE #41 LOOP ' NEXT ROAD CLOSE #2 ' VERIFIED 10/21/95 REM ************************** REM STEP 00 REM ************************** OPEN DATA40 FOR RANDOM AS #40 FOR W = 1 TO ((9 * NODES) + TERMINUS) TMNTCOST.X = 0 TMNTCOST.Y = 0 TMNTCOST.Z = 0 TMNTCOST.F = 0 TMNTCOST.V = 0 PUT #40, W, TMNTCOST NEXT W CLOSE #40 OPEN DATA4 FOR OUTPUT AS #4 OPEN DATA46 FOR INPUT AS #46 FOR Z = 1 TO 10 ' FOR EACH PERIOD 'IF POBLIT > Z THEN ' PRINT USING " PERIOD OF OBLITERATION ##"; POBLIT ' DO WHILE NOT EOF(46) ' INPUT #46, ST, TER, PERI, SED, NUMNOD, LENG ' IF PERI = POBLIT THEN ' Z = (PERI - 1) ' GOTO THEEND ' END IF ' PRINT #4, ST; TER; PERI; SED; NUMNOD; LENG; ' FOR I = 1 TO NUMNOD ' INPUT #46, NODE ' PRINT #4, NODE; ' NEXT I ' PRINT #4, ' LOOP 'END IF PRINT USING " PERIOD ##"; Z START = 0 ' STARTING NODE NUMBER TERMINUS = NODES ' THE TERMINUS NODE NUMBER OBLITTEMP = 0 LINKS = 0 OPEN DATA2 FOR INPUT AS #2 ' OPEN ROADS.prn DO WHILE NOT EOF(2) ' FOR ALL LINKS, CHECK FOR OBLIT LINKS = LINKS + 1 INPUT #2, FROMNODE, TONODE, STD, LENGTH, GEFACTOR, DISTSTR, INWS, AVGK, RDSLOPE OPEN DATA13 FOR RANDOM AS #13 ' OPEN ROADTYPE.prn GET #13, LINKS, TLINK CLOSE #13 IF Z = 1 THEN STD1 = TLINK.S1 IF Z = 2 THEN STD1 = TLINK.S2 IF Z = 3 THEN STD1 = TLINK.S3 IF Z = 4 THEN STD1 = TLINK.S4 IF Z = 5 THEN STD1 = TLINK.S5 IF Z = 6 THEN STD1 = TLINK.S6 IF Z = 7 THEN STD1 = TLINK.S7 IF Z = 8 THEN STD1 = TLINK.S8 IF Z = 9 THEN STD1 = TLINK.S9 IF Z = 10 THEN STD1 = TLINK.S10 IF STD1 = 0 THEN ' IF OBLITERATED OBLITTEMP = OBLITTEMP + 1 OPEN DATA36 FOR RANDOM AS #36 FOR V = ((FROMNODE * GAP) + 1) TO ((FROMNODE * GAP) + GAP) GET #36, V, TNEW IF TNEW.X = FROMNODE AND TNEW.Y = TONODE THEN TNEW.Z = 999999 PUT #36, V, TNEW EXIT FOR END IF NEXT V CLOSE #36 OPEN DATA36 FOR RANDOM AS #36 FOR V = ((TONODE * GAP) + 1) TO ((TONODE * GAP) + GAP) GET #36, V, TNEW IF TNEW.X = TONODE AND TNEW.Y = FROMNODE THEN TNEW.Z = 999999 PUT #36, V, TNEW EXIT FOR END IF NEXT V CLOSE #36 END IF LOOP ' GET NEXT ROAD CLOSE #2 PRINT USING " #### OBLITERATED ROADS"; OBLITTEMP IF Z > 1 AND OBLITTEMP = OBLITPERM THEN ' BYPASSING DIJKSTRA IF NO GOTO ZIGZAG ' ROADS OBLIT IN TIME Z, AS ELSE ' COMPARED TO TIME Z-1 OBLITPERM = OBLITTEMP END IF REM ************************** REM STEP 0 REM ************************** PRINT " STEP 0 - Resetting Paths" FOR I = 1 TO NODES L(I) = 999999 ' SETTING ALL TO HIGH NUMBER NEXT I L(0) = 0 START = 0 P = START REM ************************** REM STEP 1 REM ************************** PRINT " STEP 1 - Calculating Potential Paths" YAHOO: YUCK = 0 FOR P = START TO NODES ' P = FROM-NODE FOR V = ((P * GAP) + 1) TO ((P * GAP) + GAP) ' I = GAP TO FIND DIST = 999999 ' TO-NODES OPEN DATA36 FOR RANDOM AS #36 GET #36, V, TNEW CLOSE #36 OPEN DATA41 FOR RANDOM AS #41 GET #41, V, TCOST CLOSE #41 IF TNEW.X = 0 AND TNEW.Y = 0 THEN GOTO DEPOE ELSE I = TNEW.Y DIST = TNEW.Z IF Z = 1 THEN SED = TNEW.SED1 FIXED1 = TCOST.FIX1 VARIA1 = TCOST.VAR1 ELSEIF Z = 2 THEN SED = TNEW.SED2 FIXED1 = TCOST.FIX2 VARIA1 = TCOST.VAR2 ELSEIF Z = 3 THEN SED = TNEW.SED3 FIXED1 = TCOST.FIX3 VARIA1 = TCOST.VAR3 ELSEIF Z = 4 THEN SED = TNEW.SED4 FIXED1 = TCOST.FIX4 VARIA1 = TCOST.VAR4 ELSEIF Z = 5 THEN SED = TNEW.SED5 FIXED1 = TCOST.FIX5 VARIA1 = TCOST.VAR5 ELSEIF Z = 6 THEN SED = TNEW.SED6 FIXED1 = TCOST.FIX6 VARIA1 = TCOST.VAR6 ELSEIF Z = 7 THEN SED = TNEW.SED7 FIXED1 = TCOST.FIX7 VARIA1 = TCOST.VAR7 ELSEIF Z = 8 THEN SED = TNEW.SED8 FIXED1 = TCOST.FIX8 VARIA1 = TCOST.VAR8 ELSEIF Z = 9 THEN SED = TNEW.SED9 FIXED1 = TCOST.FIX9 VARIA1 = TCOST.VAR9 ELSEIF Z = 10 THEN SED = TNEW.SED10 FIXED1 = TCOST.FIX10 VARIA1 = TCOST.VAR10 END IF GOTO MYROOM END IF MYROOM: T1 = L(P) + DIST ' T1 = LENGTH(P) + DISTANCE FROM LAST ' PERM NODE (P) TO CURRENT NODE (I) S1 = S(P) + SED F1 = F(P) + FIXED1 V1 = V(P) + VARIA1 IF L(I) < T1 + 1 THEN GOTO NEWPORT ' IF CURRENT LABEL FOR NODE (I) IS LESS THAN ELSE ' T1, THEN IGNORE T1, OTHERWISE, REPLACE L(I) = T1 ' L(I) WITH T1 R(I) = P ' R() = LAST PERM NODE S(I) = S1 ' S() = SEDIMENT CONTRIBUTION F(I) = F1 ' F() = FIXED COST V(I) = V1 ' V() = VARIABLE COST YUCK = YUCK + 1 ' YUCK IS A MARKER END IF NEWPORT: NEXT V ' VERIFIED 6/28/95 DEPOE: NEXT P 'PRINT "."; IF YUCK > 0 THEN GOTO YAHOO REM *************************** REM STEP 2 REM *************************** REM VACANT PRINT " STEP 2 - All Nodes have a Path" REM *************************** REM STEP 3 ' CREATING THE PATH REM *************************** PRINT " STEP 3 - Determining Ordered Paths" ZIGZAG: T8 = NODES ' T8 = MAX NUMBER OF NODES O(T8) = TERMINUS ' PATH FROM LAST NODE = TERMINUS I = R(TERMINUS) ' PREDESESSOR NODE TO TERMINUS IS (I) PERRY: T8 = T8 - 1 IF T8 = -1 THEN GOTO ATLANTA O(T8) = I ' PATH FROM SECOND TO LAST NODE ' IN ORDERED PATH IS (I) IF I = START THEN GOTO ATLANTA ' IF (I) = START NODE, THEN PRINT PATH I = R(I) ' PREDESSOR NODE TO (I) IS (I) GOTO PERRY ' LOOP BACK TO LOCATE NEXT PREDECESSOR ATLANTA: ' FOUND PATH, NOW PRINTING 'PRINT START; TERMINUS; L(TERMINUS) 'CC = INPUT$(1) IF L(TERMINUS) < 999999 THEN ' FILLING MNTCOST.PRN PRINT #4, START; TERMINUS; Z; S(TERMINUS); (NODES - T8 + 1); L(TERMINUS); FOR I = T8 TO NODES PRINT #4, O(I); NEXT I PRINT #4, W = (((Z - 1) * NODES) + TERMINUS) OPEN DATA40 FOR RANDOM AS #40 TMNTCOST.X = START TMNTCOST.Y = TERMINUS TMNTCOST.Z = Z TMNTCOST.F = F(TERMINUS) TMNTCOST.V = V(TERMINUS) PUT #40, W, TMNTCOST CLOSE #40 OPEN DATA43 FOR RANDOM AS #43 TSED.X = START TSED.Y = TERMINUS TSED.I = Z TSED.SED = S(TERMINUS) PUT #43, W, TSED CLOSE #43 END IF TERMINUS = TERMINUS - 1 ' RESETTING TERMINUS FROM LAST ' NODE TO NEXT TO LAST NODE IF TERMINUS = START THEN GOTO TWOEGG ' IF "TERMINUS" NOW = "START", QUIT GOTO ZIGZAG ' OTHERWISE GO BACK TO THE BEGINNING ' OF STEP 3 TWOEGG: CLOSE #2 THEEND: NEXT Z ' LOOPING FOR EACH PERIOD OPEN DATA40 FOR RANDOM AS #40 FOR Z = 1 TO 10 FOR A = 1 TO NODES W = (((Z - 1) * NODES) + A) GET #40, W, TMNTCOST BBB = TMNTCOST.X ' = START CCC = TMNTCOST.Y ' = TERMINUS DDD = TMNTCOST.Z ' = Z EEE = TMNTCOST.F FFF = TMNTCOST.V IF FFF = 0 THEN FFF = 9999999 EEE = 9999999 TMNTCOST.F = 9999999 TMNTCOST.V = 9999999 PUT #40, W, TMNTCOST END IF NEXT A NEXT Z CLOSE #40 CLOSE #4 CLOSE #46 REM ******************************************************************** REM REM END DIJKSTRA'S SHORTEST PATH ALGORITHM ' COMPLETED 10/18/95 REM REM ******************************************************************** END SUB SUB ECA (W(), LINKS, UCOUNT) ' W() = ECA() REM ******************************************************************** REM REM Equivalent Clearcut Acres algorithm REM OCTOBER 28, 1995 REM REM PETE BETTINGER REM REM This algorithm calculates equivalent clearcut acres (ECA), a REM watershed index of the snowmelt and evapotranspiration rates REM relative to a baseline condition with tree stands fully canopied. REM REM Wallowa-Whitman National Forest. 1991. Predicting snowmelt-derived REM peak streamflow (WWPEAK method). Wallowa-Whitman National Forest, REM Baker City, OR. 28 p. REM REM ******************************************************************** REM COMMENTS: REM 1. CONTAINS THREE PARTS: REM PART 1: ECA FOR ROADS REM PART 2: ECA FOR UNITS REM PART 3: ECA SUMMARY FOR ANALYSIS AREA REM 2. COMPLETED 10-PERIOD ROAD AND UNIT CALCULATION REM REM ******************************************************************** COLOR 2, 0 PRINT PRINT "EQUIVALENT CLEARCUT ACRES (ECA)" COLOR 7, 0 DIM THARV AS THARVESTC DIM TLINK AS TLINKS DIM TBA AS TBASAL DIM DATA1 AS STRING ' DATA FILE FOR UNITS DATA1 = "C:\PETE\THESIS\MODULES\UNITS.PRN" DIM DATA2 AS STRING ' DATA FILE FOR ROADS DATA2 = "C:\PETE\THESIS\MODULES\ROADS.PRN" DIM DATA13 AS STRING ' DATA FILE FOR ROAD STD PER PERIOD DATA13 = "C:\PETE\THESIS\MODULES\ROADTYPE.PRN" DIM DATA14 AS STRING ' DATA FILE FOR BASAL AREA OVER TIME DATA14 = "C:\PETE\THESIS\MODULES\BA.PRN" DIM CC AS STRING ' STRING TO PAUSE RUNNING OF PROGRAM DIM COUNT AS SINGLE ' USED IN PART 1, NUMBER OF ROADS DIM FROMNODE AS SINGLE ' USED IN PART 1, FROM NODE DIM FRND AS SINGLE ' USED IN PART 1, FROM NODE DIM TONODE AS SINGLE ' USED IN PART 1, TO NODE DIM TND AS SINGLE ' USED IN PART 1, TO NODE DIM STD(10) AS SINGLE ' USED IN PART 1, ROAD STANDARD DIM D1 AS SINGLE ' USED IN PART 1, ROAD LENGTH DIM LENGTH AS SINGLE ' USED IN PART 1, ROAD LENGTH DIM GEFACTOR AS SINGLE ' USED IN PART 1&2, GEOLOGIC EROSION FACTOR DIM RDWIDTH AS SINGLE ' USED IN PART 1, ROAD WIDTH DIM TOTALRDECA(10) AS SINGLE ' USED IN PART 1, TOTAL ROAD AREA, 10 PERIODS DIM UNIT AS SINGLE ' USED IN PART 2, UNIT NUMBER DIM UNIT2 AS SINGLE ' USED IN PART 2, UNIT NUMBER DIM AREA AS SINGLE ' USED IN PART 2, UNIT AREA DIM HAZARD AS SINGLE ' USED IN PART 2, EROSION HAZARD RATING DIM SYS AS SINGLE ' USED IN PART 2, LOGGING SYSTEM DIM SLOPE AS SINGLE ' USED IN PART 2, GROUND SLOPE DIM SPP AS SINGLE ' USED IN PART 2, PLANT ASSOCIATION (SPECIES) DIM SPP2 AS SINGLE ' USED IN PART 2, PLANT ASSOCIATION (SPECIES) DIM BA(10) AS SINGLE ' USED IN PART 2, BASAL AREA PER ACRE DIM AGE AS SINGLE ' USED IN PART 2, STAND AGE DIM VOLUME AS SINGLE ' USED IN PART 2, STAND VOLUME PER ACRE DIM TOTALUNITAREA(10) AS SINGLE ' USED IN PART 2, TOTAL UNIT AREA DIM CEF AS SINGLE ' USED IN PART 2, CLEARCUT EQUIVALENT FACTOR DIM UNITECA AS SINGLE ' USED IN PART 2, ECA FOR EACH UNIT DIM TOTALUNITECA(10) AS SINGLE ' USED IN PART 2, TOTAL UNIT ECA DIM ADJUNITECA(10) AS SINGLE ' USED IN PART 3, ADJUSTED UNIT ECA DIM TECA(10) AS SINGLE ' USED IN PART 3, TOTAL ECA REM ********************************************* REM Part 1. ECA for Roads REM ********************************************* PRINT " Part 1: ECA for Roads" OPEN DATA2 FOR INPUT AS #2 ' OPEN ROADS.prn FOR I = 1 TO LINKS ' FOR ALL ROADS, CALCULATE ECA INPUT #2, FROMNODE, TONODE, STD, LENGTH, GEFACTOR, DISTSTR, INWS, AVGK, RDSLOPE OPEN DATA13 FOR RANDOM AS #13 ' OPEN ROADTYPE.prn GET #13, I, TLINK ' GET STANDARDS CLOSE #13 STD(0) = STD STD(1) = TLINK.S1 STD(2) = TLINK.S2 STD(3) = TLINK.S3 STD(4) = TLINK.S4 STD(5) = TLINK.S5 STD(6) = TLINK.S6 STD(7) = TLINK.S7 STD(8) = TLINK.S8 STD(9) = TLINK.S9 STD(10) = TLINK.S10 IF INWS = 0 THEN ' IF NOT IN WATERSHED, NEXT ROAD GOTO MRRR END IF FOR J = 1 TO 10 ' FOR EACH PERIOD IF STD(J) = 0 THEN RDWIDTH = 0 IF STD(J) = 1 THEN RDWIDTH = 52.67 IF STD(J) = 2 OR STD(J) = 3 THEN RDWIDTH = 19.35 IF STD(J - 1) = 0 THEN RDWIDTH1 = 0 IF STD(J - 1) = 1 THEN RDWIDTH1 = 52.67 IF STD(J - 1) = 2 OR STD(J - 1) = 3 THEN RDWIDTH1 = 19.35 RDAREA = ((((LENGTH * RDWIDTH) + (LENGTH * RDWIDTH1)) / 2) / 43560) TOTALRDECA(J) = TOTALRDECA(J) + RDAREA ' TOTAL ROAD ECA (AREA) NEXT J MRRR: NEXT I CLOSE #2 REM *** TOTALRDECA(J) IS THE SUM OF ROAD ECA FOR PERIOD J ************ REM *** TOTALRDECA(J) IS ALSO THE TOTAL ROAD AREA IN PERIOD J ******** REM ********************************************* REM Part 2. ECA for Units REM ********************************************* PRINT " Part 2: ECA for Units" OPEN DATA1 FOR INPUT AS #1 ' OPEN UNITS.prn DO WHILE NOT EOF(1) ' FOR ALL UNITS INPUT #1, UNIT, AREA, HAZARD, SYS, GEFACTOR, SLOPE, SPP, BA, AGE, VOLUME, DISTSTR, RIPAR, AVGK OPEN DATA14 FOR RANDOM AS #14 ' OPEN BA.prn GET #14, UNIT, TBA CLOSE #14 BA(1) = TBA.B1 BA(2) = TBA.B2 BA(3) = TBA.B3 BA(4) = TBA.B4 BA(5) = TBA.B5 BA(6) = TBA.B6 BA(7) = TBA.B7 BA(8) = TBA.B8 BA(9) = TBA.B9 BA(10) = TBA.B10 FOR J = 1 TO 10 ' FOR EVERY PERIOD IF SPP = 1 THEN ' DETERMINING ECA FOR EACH UNIT CEF = 0 ' BASED ON SPP, THEN BASAL AREA ELSEIF SPP = 2 THEN IF BA(J) = 0 THEN CEF = 1 IF BA(J) > 0 AND BA(J) < 13 THEN CEF = .9 IF BA(J) >= 13 AND BA(J) < 25 THEN CEF = .7 IF BA(J) >= 25 AND BA(J) < 47 THEN CEF = .5 IF BA(J) >= 47 AND BA(J) < 74 THEN CEF = .3 IF BA(J) >= 74 AND BA(J) < 104 THEN CEF = .1 IF BA(J) >= 104 THEN CEF = 0 ELSEIF SPP = 3 THEN IF BA(J) = 0 THEN CEF = 1 IF BA(J) > 0 AND BA(J) < 10 THEN CEF = .9 IF BA(J) >= 10 AND BA(J) < 18 THEN CEF = .7 IF BA(J) >= 18 AND BA(J) < 26 THEN CEF = .5 IF BA(J) >= 26 AND BA(J) < 39 THEN CEF = .3 IF BA(J) >= 39 AND BA(J) < 51 THEN CEF = .1 IF BA(J) >= 51 THEN CEF = 0 ELSEIF SPP = 4 THEN IF BA(J) = 0 THEN CEF = 1 IF BA(J) > 0 AND BA(J) < 7 THEN CEF = .9 IF BA(J) >= 7 AND BA(J) < 15 THEN CEF = .7 IF BA(J) >= 15 AND BA(J) < 29 THEN CEF = .5 IF BA(J) >= 29 AND BA(J) < 47 THEN CEF = .3 IF BA(J) >= 47 AND BA(J) < 76 THEN CEF = .1 IF BA(J) >= 76 THEN CEF = 0 ELSEIF SPP = 5 THEN IF BA(J) = 0 THEN CEF = 1 IF BA(J) > 0 AND BA(J) < 14 THEN CEF = .9 IF BA(J) >= 14 AND BA(J) < 25 THEN CEF = .7 IF BA(J) >= 25 AND BA(J) < 47 THEN CEF = .5 IF BA(J) >= 47 AND BA(J) < 65 THEN CEF = .3 IF BA(J) >= 65 AND BA(J) < 90 THEN CEF = .1 IF BA(J) >= 90 THEN CEF = 0 ELSEIF SPP = 6 THEN IF BA(J) = 0 THEN CEF = 1 IF BA(J) > 0 AND BA(J) < 9 THEN CEF = .9 IF BA(J) >= 9 AND BA(J) < 16 THEN CEF = .7 IF BA(J) >= 16 AND BA(J) < 24 THEN CEF = .5 IF BA(J) >= 24 AND BA(J) < 33 THEN CEF = .3 IF BA(J) >= 33 AND BA(J) < 43 THEN CEF = .1 IF BA(J) >= 43 THEN CEF = 0 END IF TOTALUNITAREA(J) = TOTALUNITAREA(J) + AREA ' TOTAL UNIT AREA UNITECA = AREA * CEF TOTALUNITECA(J) = TOTALUNITECA(J) + UNITECA ' VERIFIED 7/13/95 NEXT J LOOP CLOSE #1 REM ********************************************* REM Part 3. ECA Summary Calculations REM ********************************************* PRINT " Part 3: ECA Summary " PRINT FOR J = 1 TO 10 ' FOR EACH PERIOD WCEF = (TOTALUNITECA(J) / TOTALUNITAREA(J)) ' WEIGHTED CEF ADJUNITECA(J) = (TOTALUNITECA(J) - (WCEF * TOTALRDECA(J))) ' ADJUSTMENT ' FOR ROAD AREA TECA(J) = ((TOTALRDECA(J) + ADJUNITECA(J)) / TOTALUNITAREA(J)) * 100 ' CALCUATING ECA FOR PERIOD J PRINT USING " Total ECA, Period ## = ##.## %"; J; TECA(J) NEXT J FOR I = 1 TO 10 W(I) = TECA(I) NEXT I 'CC = INPUT$(1) REM ******************************************************************** REM REM END ECA ALGORITHM ' COMPLETED 8/1/95 REM REM ******************************************************************** END SUB SUB ECON (X, UCOUNT, NODES, LINKS) ' X = BOTTOMLINE, UCOUNT = UNITS, ' NODES = NODES, LINKS = ROADS REM ******************************************************************** REM REM Economics algorithm REM OCTOBER 26, 1995 REM REM PETE BETTINGER REM REM This algorithm determines the cost of a solution for REM simultaneously meeting aquatic habitat and commodity REM production goals. REM REM ******************************************************************** REM COMMENTS: REM 1. ALGORITM CONSISTS OF 3 PARTS: REM A. UNIT REVENUES/COSTS (DONE) REM B. ROAD MAINTENANCE (DONE) REM C. ROAD STANDARD CHANGES (DONE) REM REM ******************************************************************** COLOR 2, 0 PRINT PRINT "ECONOMICS ALGORITHM" COLOR 7, 0 DIM TENTRY AS TENTRYNODE DIM TMNTCOST AS TMAINTCOST DIM TCUT AS TCUTVOL DIM THARV AS THARVESTC DIM TUNITREV AS TUNITREVENUE DIM TUNITHAUL AS TUNITHAULCOST DIM TLINK AS TLINKS DIM DATA2 AS STRING ' DATA FILE NAME FOR ROADS DATA2 = "C:\PETE\THESIS\MODULES\ROADS.PRN" DIM DATA10 AS STRING ' HARVEST CHOICES OVER 10 PERIODS DATA10 = "C:\PETE\THESIS\MODULES\HARVEST.PRN" DIM DATA13 AS STRING ' ROAD TYPES OVER 10 PERIODS DATA13 = "C:\PETE\THESIS\MODULES\ROADTYPE.PRN" DIM DATA16 AS STRING ' UNIT HARVEST OVER 10 PERIODS DATA16 = "C:\PETE\THESIS\MODULES\CUT.PRN" DIM DATA37 AS STRING ' REVENUE FOR UNITS DATA37 = "C:\PETE\THESIS\MODULES\REVENUE.PRN" DIM DATA38 AS STRING ' HAUL COSTS FOR UNITS DATA38 = "C:\PETE\THESIS\MODULES\HAULCOST.PRN" DIM DATA40 AS STRING DATA40 = "C:\PETE\THESIS\MODULES\MNTCOST.PRN" DIM DATA42 AS STRING DATA42 = "C:\PETE\THESIS\MODULES\ENTRYRND.PRN" DIM CC AS STRING ' USED EVERYWHERE TO BREAK CODE DIM UNIT AS SINGLE ' USED IN PART 1a, UNIT NUMBER DIM UNIT1 AS SINGLE ' USED IN PART 1a, UNIT NUMBER DIM SPP AS SINGLE ' USED IN PART 1a, SPECIES DIM CUT(10) AS SINGLE ' USED IN PART 1a, HARVEST VOLUME I DIM HSYS(10) AS SINGLE ' USED IN PART 1a, HARVEST SYSTEM DIM HARVCOST(10) AS SINGLE ' USED IN PART 1a, HARVEST COST DIM HCOST(8) AS SINGLE ' USED IN PART 1a, HARVEST COST DIM REVENUE(10) AS SINGLE ' USED IN PART 1a, REVENUE IN PERIOD I DIM TOTREV(10) AS SINGLE ' USED IN PART 1a, TOTAL REVENUE I DIM STUMPAGE(6) AS SINGLE ' USED IN PART 1a, STUMPAGE RATE/SPP DIM DISCOUNT AS SINGLE ' USED IN PART 1a, DISCOUNT RATE DIM UNITREVENUE AS SINGLE ' USED IN PART 1a, TOTAL UNIT REVENUE DIM UNIT2 AS SINGLE ' USED IN PART 1b, UNIT NUMBER DIM UNIT3 AS SINGLE ' USED IN PART 1b, UNIT NUMBER DIM SYS AS SINGLE ' USED IN PART 1b, HARVEST SYSTEM DIM ENNODE AS SINGLE ' USED IN PART 1b, TIMBER ENTRY NODE DIM FRND AS SINGLE ' USED IN PART 1b, FROM NODE DIM FROMNODE AS SINGLE ' USED IN PART 1b, FROM NODE DIM NNNN AS SINGLE ' USED IN PART 1b, TEMPORARY FROM NODE DIM TND AS SINGLE ' USED IN PART 1b, TO NODE DIM TONODE AS SINGLE ' USED IN PART 1b, TO NODE DIM NEND AS SINGLE ' USED IN PART 1b, TEMPORARY TO NODE DIM PER AS SINGLE ' USED IN PART 1b, PERIOD DIM NUMNODES AS SINGLE ' USED IN PART 1b, NUMBER OF NODES DIM LENGTH AS SINGLE ' USED IN PART 1b, ROAD LENGTH DIM DIST AS SINGLE ' USED IN PART 1b, ROAD LENGTH DIM BOGUSSTD AS SINGLE ' USED IN PART 1b, BOGUS ROAD STANDARD DIM STD AS SINGLE ' USED IN PART 1b, ROAD STANDARD DIM MAINTCOST AS SINGLE ' USED IN PART 1b, MAINTENANCE COST DIM MCOST(10) AS SINGLE ' USED IN PART 1b, MAINTENANCE COST DIM GEFACTOR AS SINGLE ' USED IN PART 1c, GEOLOGIC EROSION FACTOR DIM STDCOST AS SINGLE ' USED IN PART 1c, STD CHANGE COST DIM CHANGECOST(10) AS SINGLE ' USED IN PART 1c, STD CHANGE COST DIM STANDARD(10) AS SINGLE ' USED IN PART 1c, ROAD STANDARDS DIM NPV(10) AS SINGLE ' USED IN PART 1c, NET PRESENT VALUE FOR I = 1 TO 10 NPV(I) = 0 NEXT I DIM BOTTOMLINE AS SINGLE ' USED IN PART 1c, TOTAL NPV REM ************************************************************* REM MAJOR ASSUMPTIONS REM ************************************************************* DISCOUNT = .04 ' 4% DISCOUNT RATE STUMPAGE(1) = 0 ' $0 FOR MEADOWS STUMPAGE(2) = 355 ' $/MBF FOR GRAND FIR STUMPAGE(3) = 377 ' $/MBF FOR LODGEPOLE PINE STUMPAGE(4) = 355 ' $/MBF FOR SUBALPINE FIR STUMPAGE(5) = 433 ' $/MBF FOR DOUGLAS-FIR STUMPAGE(6) = 433 ' $/MBF FOR PONDEROSA PINE HCOST(1) = 99.5 ' $/MBF FOR TRACTOR - CC HCOST(2) = 114.61 ' $/MBF FOR CABLE - CC HCOST(3) = 151.5 ' $/MBF FOR SKYLINE - CC HCOST(4) = 375 ' $/MBF FOR HELICOPTER - CC HCOST(5) = 99.5 ' $/MBF FOR TRACTOR - PC HCOST(6) = 114.61 ' $/MBF FOR CABLE - PC HCOST(7) = 151.5 ' $/MBF FOR SKYLINE - PC HCOST(8) = 375 ' $/MBF FOR HELICOPTER - PC REM ************************************************************* REM Part 1a. Unit Revenues/Costs REM ************************************************************* PRINT " Part 1a. Unit Net Present Value from Harvests" FOR I = 2 TO UCOUNT ' FOR EACH UNIT UNITREVENUE = 0 ' SET UNITREVENUE OVER TIME = 0 OPEN DATA10 FOR RANDOM AS #10 ' CALCULATING HARVESTING COSTS GET #10, I, THARV ' GET FROM HARVEST.PRN CLOSE #10 HSYS(1) = THARV.C1 ' C1 = HARVEST CHOICE, PERIOD 1 HSYS(2) = THARV.C2 ' ETC.. HSYS(3) = THARV.C3 HSYS(4) = THARV.C4 HSYS(5) = THARV.C5 HSYS(6) = THARV.C6 HSYS(7) = THARV.C7 HSYS(8) = THARV.C8 HSYS(9) = THARV.C9 HSYS(10) = THARV.C10 OPEN DATA16 FOR RANDOM AS #16 ' CALCULATING HARVEST REVENUES GET #16, I, TCUT ' GET FROM CUT.PRN CLOSE #16 SPP = TCUT.SP ' SPP = SPECIES CUT(1) = TCUT.C1 ' C1 = VOLUME CUT, PERIOD 1 CUT(2) = TCUT.C2 ' ETC... CUT(3) = TCUT.C3 CUT(4) = TCUT.C4 CUT(5) = TCUT.C5 CUT(6) = TCUT.C6 CUT(7) = TCUT.C7 CUT(8) = TCUT.C8 CUT(9) = TCUT.C9 CUT(10) = TCUT.C10 FOR J = 1 TO 10 ' CALCULATING REVENUES OVER TIME IF HSYS(J) = 0 THEN ' IF NO HARVEST IN PERIOD J, SKIP REVENUE(J) = 0 GOTO TOWN END IF 'PRINT USING "UNIT #### J ## SPP ## "; I; J; SPP 'CC = INPUT$(1) REVENUE(J) = (CUT(J) * (STUMPAGE(SPP) - HCOST(HSYS(J)))) / ((1 + DISCOUNT) ^ (J * 10 - 5)) TOTREV(J) = TOTREV(J) + REVENUE(J) TOWN: NEXT J FOR G = 1 TO 10 ' SUMMING REVENUES FOR UNIT I UNITREVENUE = UNITREVENUE + REVENUE(G) NEXT G TUNITREV.REV = UNITREVENUE OPEN DATA37 FOR RANDOM AS #37 ' OPENING REVENUE.prn FOR OUTPUT PUT #37, I, TUNITREV CLOSE #37 NEXT I ' VERIFIED 8/22/95 REM ************************************************************* REM Part 1b. Road Maintenance Costs REM ************************************************************* PRINT " Part 1b. Net Present Value of Road Maintenance" FOR I = 2 TO UCOUNT ' FOR EACH UNIT UNITHAULCOST = 0 ' SET HAUL COST / UNIT = 0 OPEN DATA10 FOR RANDOM AS #10 ' OPEN HARVEST.prn GET #10, I, THARV ' GET FROM HARVEST.PRN CLOSE #10 HSYS(1) = THARV.C1 ' C1 = HARVEST CHOICE, PERIOD 1 HSYS(2) = THARV.C2 ' ETC.. HSYS(3) = THARV.C3 HSYS(4) = THARV.C4 HSYS(5) = THARV.C5 HSYS(6) = THARV.C6 HSYS(7) = THARV.C7 HSYS(8) = THARV.C8 HSYS(9) = THARV.C9 HSYS(10) = THARV.C10 OPEN DATA16 FOR RANDOM AS #16 ' OPEN CUT.prn GET #16, I, TCUT ' GET FROM CUT.PRN CLOSE #16 SPP = TCUT.SP ' SPP = SPECIES CUT(1) = TCUT.C1 ' C1 = VOLUME CUT, PERIOD 1 CUT(2) = TCUT.C2 ' ETC... CUT(3) = TCUT.C3 CUT(4) = TCUT.C4 CUT(5) = TCUT.C5 CUT(6) = TCUT.C6 CUT(7) = TCUT.C7 CUT(8) = TCUT.C8 CUT(9) = TCUT.C9 CUT(10) = TCUT.C10 FOR J = 1 TO 10 ' FOR EACH PERIOD IF HSYS(J) = 0 THEN GOTO BOONIES ' IF NO HARVEST, NEXT I W = (((HSYS(J) - 1) * UCOUNT) + I) OPEN DATA42 FOR RANDOM AS #42 ' OPEN ENTRYRND.prn GET #42, W, TENTRY ENNODE = TENTRY.E CLOSE #42 ' VERIFIED 8/23/95 - ENTRY NODE CORRECT W = (((J - 1) * NODES) + ENNODE) OPEN DATA40 FOR RANDOM AS #40 ' OPEN MNTCOST.PRN GET #40, W, TMNTCOST FIXEDC = TMNTCOST.F VARIAC = TMNTCOST.V CLOSE #40 MCOST(J) = MCOST(J) + ((FIXEDC + (VARIAC * CUT(J))) / (1.04 ^ (J * 10 - 5)))' SUMMING MAINTENANCE COSTS UNITHAULCOST = UNITHAULCOST + ((FIXEDC + (VARIAC * CUT(J))) / (1.04 ^ (J * 10 - 5))) 'PRINT USING "UNIT ##### PERIOD #### SYSTEM #### CUT ####.##"; I; J; HSYS(J); CUT(J) 'PRINT USING "FIXED ###.### VAR ###.### MCOST ####.###"; FIXEDC; VARIAC; ((FIXEDC + (VARIAC * CUT(J))) / (1.04 ^ (J * 10 - 5))) 'CC = INPUT$(1) BOONIES: NEXT J ' MAINTENANCE COST LOOP TUNITHAUL.C = UNITHAULCOST OPEN DATA38 FOR RANDOM AS #38 ' OPEN HAULCOST.prn PUT #38, I, TUNITHAUL CLOSE #38 NEXT I ' VERIFIED 8/23/95 REM ************************************************************* REM Part 1c. Road Standard Change Costs REM ************************************************************* PRINT " Part 1c. Net Present Value of Road Standard Changes" OPEN DATA2 FOR INPUT AS #2 ' OPEN ROADS.prn FOR I = 1 TO LINKS INPUT #2, FROMNODE, TONODE, STD, LENGTH, GEFACTOR, DISTSTR, INWS, AVGK, RDSLOPE IF INWS = 0 THEN GOTO MRRAK ' ROAD NOT IN WATERSHED OPEN DATA13 FOR RANDOM AS #13 ' OPEN ROADTYPE.prn GET #13, I, TLINK ' GET FROM ROADTYPE.PRN CLOSE #13 STANDARD(0) = STD ' STD = STANDARD IN PERIOD 0 STANDARD(1) = TLINK.S1 ' S1 = STANDARD IN PERIOD 1 STANDARD(2) = TLINK.S2 ' ETC.. STANDARD(3) = TLINK.S3 STANDARD(4) = TLINK.S4 STANDARD(5) = TLINK.S5 STANDARD(6) = TLINK.S6 STANDARD(7) = TLINK.S7 STANDARD(8) = TLINK.S8 STANDARD(9) = TLINK.S9 STANDARD(10) = TLINK.S10 FOR J = 1 TO 10 ' FOR EACH PERIOD STDCOST = 0 ' SET STANDARD CHANGE COST = 0 IF STANDARD(J) = 0 AND STANDARD(J - 1) > 0 THEN STDCOST = (500 * (LENGTH / 5280)) CHANGECOST(J) = CHANGECOST(J) + STDCOST ' SUMMING ACROSS PERIODS END IF NEXT J MRRAK: NEXT I ' VERIFIED 8/24/95 CLOSE #2 FOR M = 1 TO 10 ' DISCOUNTING CHANGECOST(M) = CHANGECOST(M) / ((1 + DISCOUNT) ^ (M * 10 - 5)) NEXT M ' VERIFIED 8/24/95 REM ************************************************************* REM Summary of ECON.bas REM ************************************************************* FOR M = 1 TO 10 ' SUMMING PARTS 1a-1c NPV(M) = TOTREV(M) - MCOST(M) - CHANGECOST(M) NEXT M ' VERIFIED 8/24/95 BOTTOMLINE = 0 FOR M = 1 TO 10 BOTTOMLINE = NPV(M) + BOTTOMLINE NEXT M X = BOTTOMLINE PRINT USING " Net Present Value = ###,###,###.##"; X REM ******************************************************************** REM REM END ECONOMICS ALGORITHM ' COMPLETED 8/24/95 REM REM ******************************************************************** END SUB SUB FLIP (UCOUNT, LINKS) REM *********************************************************** REM REM A SUBROUTINE TO FLIP THE TEMPORARY CANDIDATE FILES REM INTO THE PERMANENT FILES (UNIT CHOICES ONLY) REM OCTOBER 26, 1995 REM REM *********************************************************** COLOR 2, 0 PRINT PRINT "FLIPPING THE CANDIDATE..........." COLOR 7, 0 DIM THARV AS THARVESTC DIM TCUT AS TCUTVOL DIM TBA AS TBASAL DIM THT AS THEIGHTS DIM DATA10 AS STRING DATA10 = "C:\PETE\THESIS\MODULES\HARVEST.PRN" DIM DATA14 AS STRING DATA14 = "C:\PETE\THESIS\MODULES\BA.PRN" DIM DATA15 AS STRING DATA15 = "C:\PETE\THESIS\MODULES\HEIGHT.PRN" DIM DATA16 AS STRING DATA16 = "C:\PETE\THESIS\MODULES\CUT.PRN" DIM DATA22 AS STRING DATA22 = "C:\PETE\THESIS\MODULES\CANDIDAT.PRN" DIM DATA23 AS STRING DATA23 = "C:\PETE\THESIS\MODULES\TEMPBA.PRN" DIM DATA24 AS STRING DATA24 = "C:\PETE\THESIS\MODULES\TEMPHT.PRN" DIM DATA25 AS STRING DATA25 = "C:\PETE\THESIS\MODULES\TEMPCUT.PRN" DIM HSYS(10) AS SINGLE DIM CUT(10) AS SINGLE DIM PCUT(10) AS SINGLE REM ******************************************************* REM Part 1. Flipping the Harvest REM ******************************************************* PRINT " Flipping HARVEST.PRN" OPEN DATA22 FOR INPUT AS #22 INPUT #22, UNIT, SILV, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 CLOSE #22 OPEN DATA10 FOR RANDOM AS #10 ' FLIPPING HARVEST CHOICES FOR OPEN DATA22 FOR OUTPUT AS #22 ' FOR THE CANDIDATE INTO GET #10, UNIT, THARV ' HARVEST.PRN SILV1 = THARV.SILV CT1 = THARV.C1 CT2 = THARV.C2 CT3 = THARV.C3 CT4 = THARV.C4 CT5 = THARV.C5 CT6 = THARV.C6 CT7 = THARV.C7 CT8 = THARV.C8 CT9 = THARV.C9 CT10 = THARV.C10 PRINT #22, UNIT; SILV1; CT1; CT2; CT3; CT4; CT5; CT6; CT7; CT8; CT9; CT10 THARV.SILV = SILV THARV.C1 = A1 THARV.C2 = A2 THARV.C3 = A3 THARV.C4 = A4 THARV.C5 = A5 THARV.C6 = A6 THARV.C7 = A7 THARV.C8 = A8 THARV.C9 = A9 THARV.C10 = A10 HSYS(1) = A1 HSYS(2) = A2 HSYS(3) = A3 HSYS(4) = A4 HSYS(5) = A5 HSYS(6) = A6 HSYS(7) = A7 HSYS(8) = A8 HSYS(9) = A9 HSYS(10) = A10 PUT #10, UNIT, THARV CLOSE #10 CLOSE #22 REM ******************************************************* REM Part 2. Flipping the Basal Area REM ******************************************************* PRINT " Flipping BA.PRN" OPEN DATA23 FOR INPUT AS #23 INPUT #23, UNIT, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 CLOSE #23 OPEN DATA14 FOR RANDOM AS #14 ' FLIPPING BASAL AREA FOR THE OPEN DATA23 FOR OUTPUT AS #23 ' CANDIDATE INTO BA.PRN GET #14, UNIT, TBA CT1 = TBA.B1 CT2 = TBA.B2 CT3 = TBA.B3 CT4 = TBA.B4 CT5 = TBA.B5 CT6 = TBA.B6 CT7 = TBA.B7 CT8 = TBA.B8 CT9 = TBA.B9 CT10 = TBA.B10 PRINT #23, UNIT; CT1; CT2; CT3; CT4; CT5; CT6; CT7; CT8; CT9; CT10 TBA.B1 = A1 TBA.B2 = A2 TBA.B3 = A3 TBA.B4 = A4 TBA.B5 = A5 TBA.B6 = A6 TBA.B7 = A7 TBA.B8 = A8 TBA.B9 = A9 TBA.B10 = A10 PUT #14, UNIT, TBA CLOSE #14 CLOSE #23 REM ******************************************************* REM Part 3. Flipping the Height REM ******************************************************* PRINT " Flipping HEIGHT.PRN" OPEN DATA24 FOR INPUT AS #24 INPUT #24, UNIT, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 CLOSE #24 OPEN DATA15 FOR RANDOM AS #15 ' FLIPPING TREE HEIGHTS FOR THE OPEN DATA24 FOR OUTPUT AS #24 ' CANDIDATE INTO HEIGHTS.PRN GET #15, UNIT, THT CT1 = THT.H1 CT2 = THT.H2 CT3 = THT.H3 CT4 = THT.H4 CT5 = THT.H5 CT6 = THT.H6 CT7 = THT.H7 CT8 = THT.H8 CT9 = THT.H9 CT10 = THT.H10 PRINT #24, UNIT; CT1; CT2; CT3; CT4; CT5; CT6; CT7; CT8; CT9; CT10 THT.H1 = A1 THT.H2 = A2 THT.H3 = A3 THT.H4 = A4 THT.H5 = A5 THT.H6 = A6 THT.H7 = A7 THT.H8 = A8 THT.H9 = A9 THT.H10 = A10 PUT #15, UNIT, THT CLOSE #15 CLOSE #24 REM ******************************************************* REM Part 4. Flipping the Cut REM ******************************************************* PRINT " Flipping CUT.PRN" OPEN DATA25 FOR INPUT AS #25 INPUT #25, UNIT, SPP, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 CLOSE #25 OPEN DATA16 FOR RANDOM AS #16 ' FLIPPING VOLUME CUT FOR CANDIDATE OPEN DATA25 FOR OUTPUT AS #25 ' INTO CUT.PRN GET #16, UNIT, TCUT SPP1 = TCUT.SP CT1 = TCUT.C1 CT2 = TCUT.C2 CT3 = TCUT.C3 CT4 = TCUT.C4 CT5 = TCUT.C5 CT6 = TCUT.C6 CT7 = TCUT.C7 CT8 = TCUT.C8 CT9 = TCUT.C9 CT10 = TCUT.C10 PCUT(1) = TCUT.C1 PCUT(2) = TCUT.C2 PCUT(3) = TCUT.C3 PCUT(4) = TCUT.C4 PCUT(5) = TCUT.C5 PCUT(6) = TCUT.C6 PCUT(7) = TCUT.C7 PCUT(8) = TCUT.C8 PCUT(9) = TCUT.C9 PCUT(10) = TCUT.C10 PRINT #25, UNIT; SPP1; CT1; CT2; CT3; CT4; CT5; CT6; CT7; CT8; CT9; CT10 TCUT.SP = SPP TCUT.C1 = A1 TCUT.C2 = A2 TCUT.C3 = A3 TCUT.C4 = A4 TCUT.C5 = A5 TCUT.C6 = A6 TCUT.C7 = A7 TCUT.C8 = A8 TCUT.C9 = A9 TCUT.C10 = A10 CUT(1) = A1 CUT(2) = A2 CUT(3) = A3 CUT(4) = A4 CUT(5) = A5 CUT(6) = A6 CUT(7) = A7 CUT(8) = A8 CUT(9) = A9 CUT(10) = A10 PUT #16, UNIT, TCUT CLOSE #16 CLOSE #25 REM ******************************************************* REM Part 5. Flipping the Road Use REM ******************************************************* PRINT " Flipping ROADUSE.PRN" PLUSMINUS = 1 CALL ROADUSE(UCOUNT, LINKS, UNIT, HSYS(), CUT(), PCUT(), PLUSMINUS) REM *********************************************************** REM REM END - A SUBROUTINE TO FLIP THE TEMPORARY CANDIDATE FILES REM INTO THE PERMANENT FILES REM REM *********************************************************** END SUB SUB FLIPBACK (UCOUNT, LINKS) REM *********************************************************** REM REM A SUBROUTINE TO FLIP BACK THE ORIGINAL DATA TO REM THE PERMANENT FILES (UNIT CHOICES ONLY) REM NOVEMBER 2, 1995 REM REM *********************************************************** DIM THARV AS THARVESTC DIM TBA AS TBASAL DIM THT AS THEIGHTS DIM TCUT AS TCUTVOL DIM DATA10 AS STRING DATA10 = "C:\PETE\THESIS\MODULES\HARVEST.PRN" DIM DATA14 AS STRING DATA14 = "C:\PETE\THESIS\MODULES\BA.PRN" DIM DATA15 AS STRING DATA15 = "C:\PETE\THESIS\MODULES\HEIGHT.PRN" DIM DATA16 AS STRING DATA16 = "C:\PETE\THESIS\MODULES\CUT.PRN" DIM DATA22 AS STRING DATA22 = "C:\PETE\THESIS\MODULES\CANDIDAT.PRN" DIM DATA23 AS STRING DATA23 = "C:\PETE\THESIS\MODULES\TEMPBA.PRN" DIM DATA24 AS STRING DATA24 = "C:\PETE\THESIS\MODULES\TEMPHT.PRN" DIM DATA25 AS STRING DATA25 = "C:\PETE\THESIS\MODULES\TEMPCUT.PRN" DIM HSYS(10) AS SINGLE DIM CUT(10) AS SINGLE DIM PCUT(10) AS SINGLE COLOR 2, 0 PRINT PRINT "CANDIDATE FAILED, FLIPPING BACK THE ORIGINAL DATA..........." COLOR 7, 0 REM ******************************************************* REM Part 1. Flipping the Harvest REM ******************************************************* PRINT " Flipping back to HARVEST.PRN" OPEN DATA22 FOR INPUT AS #22 INPUT #22, UNIT, SILV, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 CLOSE #22 OPEN DATA10 FOR RANDOM AS #10 GET #10, UNIT, THARV HSYS(1) = THARV.C1 HSYS(2) = THARV.C2 HSYS(3) = THARV.C3 HSYS(4) = THARV.C4 HSYS(5) = THARV.C5 HSYS(6) = THARV.C6 HSYS(7) = THARV.C7 HSYS(8) = THARV.C8 HSYS(9) = THARV.C9 HSYS(10) = THARV.C10 CLOSE #10 REM ******************************************************* REM Part 2. Flipping the Basal Area REM ******************************************************* PRINT " Flipping back to BA.PRN" OPEN DATA23 FOR INPUT AS #23 INPUT #23, UNIT, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 CLOSE #23 OPEN DATA14 FOR RANDOM AS #14 TBA.B1 = A1 TBA.B2 = A2 TBA.B3 = A3 TBA.B4 = A4 TBA.B5 = A5 TBA.B6 = A6 TBA.B7 = A7 TBA.B8 = A8 TBA.B9 = A9 TBA.B10 = A10 PUT #14, UNIT, TBA CLOSE #14 REM ******************************************************* REM Part 3. Flipping the Height REM ******************************************************* PRINT " Flipping back to HEIGHT.PRN" OPEN DATA24 FOR INPUT AS #24 INPUT #24, UNIT, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 CLOSE #24 OPEN DATA15 FOR RANDOM AS #15 THT.H1 = A1 THT.H2 = A2 THT.H3 = A3 THT.H4 = A4 THT.H5 = A5 THT.H6 = A6 THT.H7 = A7 THT.H8 = A8 THT.H9 = A9 THT.H10 = A10 PUT #15, UNIT, THT CLOSE #15 REM ******************************************************* REM Part 4. Flipping the Cut REM ******************************************************* PRINT " Flipping back to CUT.PRN" OPEN DATA25 FOR INPUT AS #25 INPUT #25, UNIT, SPP, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 CLOSE #25 OPEN DATA16 FOR RANDOM AS #16 GET #16, UNIT, TCUT PCUT(1) = TCUT.C1 PCUT(2) = TCUT.C2 PCUT(3) = TCUT.C3 PCUT(4) = TCUT.C4 PCUT(5) = TCUT.C5 PCUT(6) = TCUT.C6 PCUT(7) = TCUT.C7 PCUT(8) = TCUT.C8 PCUT(9) = TCUT.C9 PCUT(10) = TCUT.C10 TCUT.SP = SPP TCUT.C1 = A1 TCUT.C2 = A2 TCUT.C3 = A3 TCUT.C4 = A4 TCUT.C5 = A5 TCUT.C6 = A6 TCUT.C7 = A7 TCUT.C8 = A8 TCUT.C9 = A9 TCUT.C10 = A10 CUT(1) = A1 CUT(2) = A2 CUT(3) = A3 CUT(4) = A4 CUT(5) = A5 CUT(6) = A6 CUT(7) = A7 CUT(8) = A8 CUT(9) = A9 CUT(10) = A10 PUT #16, UNIT, TCUT CLOSE #16 REM ******************************************************* REM Part 5. Flipping the Road Use REM ******************************************************* PRINT " Flipping back to ROADUSE.PRN" PLUSMINUS = 1 CALL ROADUSE(UCOUNT, LINKS, UNIT, HSYS(), CUT(), PCUT(), PLUSMINUS) REM ******************************************************* REM Part 6. Flipping the Harvest REM ******************************************************* PRINT " Flipping back to HARVEST.PRN" OPEN DATA22 FOR INPUT AS #22 INPUT #22, UNIT, SILV, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 CLOSE #22 OPEN DATA10 FOR RANDOM AS #10 THARV.SILV = SILV THARV.C1 = A1 THARV.C2 = A2 THARV.C3 = A3 THARV.C4 = A4 THARV.C5 = A5 THARV.C6 = A6 THARV.C7 = A7 THARV.C8 = A8 THARV.C9 = A9 THARV.C10 = A10 PUT #10, UNIT, THARV CLOSE #10 REM *********************************************************** REM REM END - A SUBROUTINE TO FLIP BACK THE ORIGINAL DATA REM TO THE PERMANENT FILES REM REM *********************************************************** END SUB SUB GROWTH (B, UCOUNT, LINKS) REM ******************************************************************** REM REM Growth and Yield algorithm REM NOVEMBER 6, 1995 REM REM PETE BETTINGER REM REM This algorithm determines stand volume and basal area, REM from stand age and plant association. REM REM Wallowa-Whitman National Forest. 1994. Growth tables derived from REM prognosis. Wallowa-Whitman National Forest, La Grande, OR. REM REM ******************************************************************** REM COMMENTS: REM 1. Part 1 - Determining Stand Age and Volume Over Time REM 2. Part 1a - Stand Ages and Heights REM 3. Part 1b - Stand Volume and Basal Area (VOL() and CUT() REM are total MBF values, not per-acre values) REM REM 4. REMEMBER TO CREATE OTHER GROWTH FILES, AND CHANGE THEIR REM NAMES IN THE DECLARATIONS BELOW REM 5. Altered code to allow printing to "NOCUT***.prn" files REM ******************************************************************** COLOR 2, 0 PRINT PRINT "STAND GROWTH ALGORITHM" COLOR 7, 0 DIM THARV AS THARVESTC DIM TGY AS TGROWTH DIM TNCUTA AS TNOCUTAGE DIM TNCUTV AS TNOCUTVOL DIM TBA AS TBASAL DIM THT AS THEIGHTS DIM TCUT AS TCUTVOL DIM DATA1 AS STRING ' DATA FILE FOR UNITS DATA1 = "C:\PETE\THESIS\MODULES\UNITS.PRN" DIM DATA10 AS STRING ' DATA FILE HARVEST.prn DATA10 = "C:\PETE\THESIS\MODULES\HARVEST.PRN" DIM DATA14 AS STRING ' DATA FILE BA.prn DATA14 = "C:\PETE\THESIS\MODULES\BA.PRN" DIM DATA15 AS STRING ' DATA FILE HEIGHT.prn DATA15 = "C:\PETE\THESIS\MODULES\HEIGHT.PRN" DIM DATA16 AS STRING ' DATA FILE CUT.prn DATA16 = "C:\PETE\THESIS\MODULES\CUT.PRN" DIM DATA18 AS STRING ' DATA FILE NOCUTVOL.PRN DATA18 = "C:\PETE\THESIS\MODULES\NOCUTVOL.PRN" DIM DATA20 AS STRING ' DATA FILE NOCUTAGE.PRN DATA20 = "C:\PETE\THESIS\MODULES\NOCUTAGE.PRN" DIM DATA92 AS STRING ' DATA FILE CW.prn DATA92 = "C:\PETE\THESIS\MODULES\CWRND.PRN" DIM DATA93 AS STRING ' DATA FILE CL.prn DATA93 = "C:\PETE\THESIS\MODULES\CLRND.PRN" DIM DATA94 AS STRING ' DATA FILE CE.prn DATA94 = "C:\PETE\THESIS\MODULES\CERND.PRN" DIM DATA95 AS STRING ' DATA FILE CD.prn DATA95 = "C:\PETE\THESIS\MODULES\CDRND.PRN" DIM DATA96 AS STRING ' DATA FILE CP.prn DATA96 = "C:\PETE\THESIS\MODULES\CPRND.PRN" DIM CC AS STRING ' STRING TO PAUSE RUNNING OF PROGRAM DIM COUNT AS SINGLE ' USED IN PART 1, NUMBER OF UNITS DIM UNIT AS SINGLE ' USED IN PART 1, UNIT NUMBER DIM AREA AS SINGLE ' USED IN PART 1, UNIT AREA DIM HAZARD AS SINGLE ' USED IN PART 1, EROSION HAZARD RATING DIM SYS AS SINGLE ' USED IN PART 1, LOGGING SYSTEM DIM SLOPE AS SINGLE ' USED IN PART 1, GROUND SLOPE DIM GEFACTOR AS SINGLE ' USED IN PART 1, GEOLOGIC EROSION FACTOR DIM SPP AS SINGLE ' USED IN PART 1, PLANT ASSOCIATION (SPECIES) DIM BA AS SINGLE ' USED IN PART 1, BASAL AREA PER ACRE DIM AGE AS SINGLE ' USED IN PART 1a, STAND AGE DIM VOLUME AS SINGLE ' USED IN PART 1a, STAND VOLUME PER ACRE DIM HSYS(10) AS SINGLE ' USED IN PART 1a, HARVEST TYPE FOR UNIT I DIM SAGE(10) AS SINGLE ' USED IN PART 1a, AGE FOR UNIT I DIM HEIGHT(10) AS SINGLE ' USED IN PART 1a, TREE HEIGHTS DIM VOL(10) AS SINGLE ' USED IN PART 1b, STAND VOLUME FOR UNIT I DIM CUT(10) AS SINGLE ' USED IN PART 1b, STAND HARVEST FOR UNIT I DIM PCUT(10) AS SINGLE ' USED IN PART 1b, STAND PREVIOUS HARVEST DIM BASAL(10) AS SINGLE ' USED IN PART 1b, BASAL AREA FOR UNIT I DIM TOOT AS SINGLE ' USED IN PART 1b, A FLAG FOR CLEARCUTTING DIM PERCENTCUT AS SINGLE ' USED IN PART 1b, PARTIAL CUT PERCENT PERCENTCUT = .33 ' PERCENT OF STAND CUT IN PARTIAL CUT SLINK = 1 REM ****************************************************** REM Part 1. Determining Stand Age and Volume Over Time REM ****************************************************** OPEN DATA1 FOR INPUT AS #1 ' UNITS FILE - UNITS.prn REM *********************************************************** REM Part 1a. Determining Stand Ages and Heights Over Time REM *********************************************************** PRINT " Part 1a: Stand Ages and Heights Over Time" FOR I = 2 TO UCOUNT ' FOR EACH UNIT TOOT = 0 INPUT #1, UNIT, AREA, HAZARD, SYS, GEFACTOR, SLOPE, SPP, BA, AGE, VOLUME, DISTSTR, RIPAR, AVGK OPEN DATA10 FOR RANDOM AS #10 ' HARVEST FILE - HARVEST.prn GET #10, UNIT, THARV CLOSE #10 HSYS(1) = THARV.C1 HSYS(2) = THARV.C2 HSYS(3) = THARV.C3 HSYS(4) = THARV.C4 HSYS(5) = THARV.C5 HSYS(6) = THARV.C6 HSYS(7) = THARV.C7 HSYS(8) = THARV.C8 HSYS(9) = THARV.C9 HSYS(10) = THARV.C10 SAGE(0) = AGE FOR K = 1 TO 10 ' FOR EACH PERIOD - AGE AT MIDPT. CUT(K) = 0 ' CUT = 0 IF HSYS(K - 1) > 0 AND HSYS(K - 1) < 5 THEN ' IF CC IN (t-1) SAGE(K) = 10 ' AGE AT t IS 10 ELSE SAGE(K) = 10 + SAGE(K - 1) ' ELSE AGE t = 10 + AGE END IF ' (t-1) IF HSYS(K) > 0 AND HSYS(K) < 5 THEN ' IF CC IN t, HEIGHT = 0 HEIGHT(K) = 0 ELSE RAGE = INT(SAGE(K) / 10) ' ELSE, CALCULATE HEIGHT IF RAGE = 0 THEN RAGE = 1 IF RAGE > 30 THEN RAGE = 30 IF SPP = 1 THEN HEIGHT(K) = 0 IF SPP = 2 THEN OPEN DATA92 FOR RANDOM AS #92 GET #92, RAGE, TGY CLOSE #92 HEIGHT(K) = TGY.HT ELSEIF SPP = 3 THEN OPEN DATA93 FOR RANDOM AS #93 GET #93, RAGE, TGY CLOSE #93 HEIGHT(K) = TGY.HT ELSEIF SPP = 4 THEN OPEN DATA94 FOR RANDOM AS #94 GET #94, RAGE, TGY CLOSE #94 HEIGHT(K) = TGY.HT ELSEIF SPP = 5 THEN OPEN DATA95 FOR RANDOM AS #95 GET #95, RAGE, TGY CLOSE #95 HEIGHT(K) = TGY.HT ELSEIF SPP = 6 THEN OPEN DATA96 FOR RANDOM AS #96 GET #96, RAGE, TGY CLOSE #96 HEIGHT(K) = TGY.HT END IF END IF ' HEIGHT CODE VERIFIED 8/7/95 NEXT K ' AGES CODE VERIFIED 7/18/95 IF B = 0 THEN ' IF ITERATION = 0 TNCUTA.A1 = SAGE(1) ' PUT NO-CUT AGES IN DATA20 TNCUTA.A2 = SAGE(2) ' NOCUTAGE.PRN TNCUTA.A3 = SAGE(3) TNCUTA.A4 = SAGE(4) TNCUTA.A5 = SAGE(5) TNCUTA.A6 = SAGE(6) TNCUTA.A7 = SAGE(7) TNCUTA.A8 = SAGE(8) TNCUTA.A9 = SAGE(9) TNCUTA.A10 = SAGE(10) OPEN DATA20 FOR RANDOM AS #20 ' NO CUT AGE FILE - NOCUTAGE.prn PUT #20, UNIT, TNCUTA CLOSE #20 END IF IF B > 0 THEN ' IF ITERATION > 0 THT.H1 = HEIGHT(1) ' PUT HEIGHTS IN HEIGHT.PRN THT.H2 = HEIGHT(2) THT.H3 = HEIGHT(3) THT.H4 = HEIGHT(4) THT.H5 = HEIGHT(5) THT.H6 = HEIGHT(6) THT.H7 = HEIGHT(7) THT.H8 = HEIGHT(8) THT.H9 = HEIGHT(9) THT.H10 = HEIGHT(10) OPEN DATA15 FOR RANDOM AS #15 ' TREE HEIGHT FILE - HEIGHT.prn PUT #15, UNIT, THT CLOSE #15 END IF REM *************************************************************** REM Part 1b. Determining Stand Volume and Basal Area Over Time REM *************************************************************** TOOT = 0 VOL(0) = VOLUME ' INITIAL VOLUME BASAL(0) = BA ' INITIAL BASAL AREA FOR L = 1 TO 10 ' FOR EACH PERIOD IF HSYS(L - 1) > 0 AND HSYS(L - 1) < 5 THEN TOOT = 1 IF HSYS(L) > 0 THEN TOOT = 0 IF TOOT = 1 THEN ' IF CC IN (t-1) OR PREVIOUS ' PERIOD t TAGE = INT(SAGE(L) / 10) ' VOLUME AND BASAL AREA IF TAGE < .1 THEN TAGE = 1 IF SPP = 2 THEN ' ARE FROM THE GROWTH AND OPEN DATA92 FOR RANDOM AS #92 ' YIELD TABLES FOR A GET #92, TAGE, TGY ' REGULATED FOREST CLOSE #92 ELSEIF SPP = 3 THEN OPEN DATA93 FOR RANDOM AS #93 GET #93, TAGE, TGY CLOSE #93 ELSEIF SPP = 4 THEN OPEN DATA94 FOR RANDOM AS #94 GET #94, TAGE, TGY CLOSE #94 ELSEIF SPP = 5 THEN OPEN DATA95 FOR RANDOM AS #95 GET #95, TAGE, TGY CLOSE #95 ELSEIF SPP = 6 THEN OPEN DATA96 FOR RANDOM AS #96 GET #96, TAGE, TGY CLOSE #96 END IF BASAL(L) = TGY.BA ' BASAL AREA, REGULATED FOREST VOL(L) = TGY.MBF ' VOLUME, REGULATED FOREST ELSE ' IF NOT CLEARCUT IN (t-1) TAGE = INT(SAGE(L) / 10) IF TAGE = 0 OR TAGE = -1 THEN TAGE = 1 IF SPP = 1 THEN ' IF MEADOW VOL(L) = VOL(L - 1) ' NO GROWTH BASAL(L) = BASAL(L - 1) ELSEIF SPP = 2 THEN ' IF GRAND FIR OPEN DATA92 FOR RANDOM AS #92 ' OPEN CW.prn GET #92, TAGE, TGY CLOSE #92 IF HSYS(L) > 0 THEN IF HSYS(L) < 5 THEN ' CALC CLEARCUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE CUT(L) = VOL(L - 1) * TGY.MBFRATE ELSE ' CALC PARTIAL CUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE * (1 - PERCENTCUT) CUT(L) = VOL(L - 1) * TGY.MBFRATE * (PERCENTCUT) END IF ELSE VOL(L) = VOL(L - 1) * TGY.MBFRATE END IF IF HSYS(L) > 4 THEN ' CALC BA BASAL(L) = BASAL(L - 1) * TGY.BARATE * (1 - PERCENTCUT) ELSE IF HSYS(L) > 0 THEN BASAL(L) = 0 GOTO PORT2 ELSE BASAL(L) = BASAL(L - 1) * TGY.BARATE END IF END IF ELSEIF SPP = 3 THEN ' IF LODGEPOLE PINE OPEN DATA93 FOR RANDOM AS #93 ' OPEN CL.prn GET #93, TAGE, TGY CLOSE #93 IF HSYS(L) > 0 THEN IF HSYS(L) < 5 THEN ' CALC CLEARCUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE CUT(L) = VOL(L - 1) * TGY.MBFRATE ELSE ' CALC PARTIAL CUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE * (1 - PERCENTCUT) CUT(L) = VOL(L - 1) * TGY.MBFRATE * (PERCENTCUT) END IF ELSE VOL(L) = VOL(L - 1) * TGY.MBFRATE END IF IF HSYS(L) > 4 THEN ' CALC BA BASAL(L) = BASAL(L - 1) * TGY.BARATE * (1 - PERCENTCUT) ELSE IF HSYS(L) > 0 THEN BASAL(L) = 0 GOTO PORT2 ELSE BASAL(L) = BASAL(L - 1) * TGY.BARATE END IF END IF ELSEIF SPP = 4 THEN ' IF SUBALPINE FIR OPEN DATA94 FOR RANDOM AS #94 ' OPEN CE.prn GET #94, TAGE, TGY CLOSE #94 IF HSYS(L) > 0 THEN IF HSYS(L) < 5 THEN ' CALC CLEARCUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE CUT(L) = VOL(L - 1) * TGY.MBFRATE ELSE ' CALC PARTIAL CUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE * (1 - PERCENTCUT) CUT(L) = VOL(L - 1) * TGY.MBFRATE * (PERCENTCUT) END IF ELSE VOL(L) = VOL(L - 1) * TGY.MBFRATE END IF IF HSYS(L) > 4 THEN ' CALC BA BASAL(L) = BASAL(L - 1) * TGY.BARATE * (1 - PERCENTCUT) ELSE IF HSYS(L) > 0 THEN BASAL(L) = 0 GOTO PORT2 ELSE BASAL(L) = BASAL(L - 1) * TGY.BARATE END IF END IF ELSEIF SPP = 5 THEN ' IF DOUGLAS-FIR OPEN DATA95 FOR RANDOM AS #95 ' OPEN CD.prn GET #95, TAGE, TGY CLOSE #95 IF HSYS(L) > 0 THEN IF HSYS(L) < 5 THEN ' CALC CLEARCUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE CUT(L) = VOL(L - 1) * TGY.MBFRATE ELSE ' CALC PARTIAL CUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE * (1 - PERCENTCUT) CUT(L) = VOL(L - 1) * TGY.MBFRATE * (PERCENTCUT) END IF ELSE VOL(L) = VOL(L - 1) * TGY.MBFRATE END IF IF HSYS(L) > 4 THEN ' CALC BA BASAL(L) = BASAL(L - 1) * TGY.BARATE * (1 - PERCENTCUT) ELSE IF HSYS(L) > 0 THEN BASAL(L) = 0 GOTO PORT2 ELSE BASAL(L) = BASAL(L - 1) * TGY.BARATE END IF END IF ELSEIF SPP = 6 THEN ' IF PONDEROSA PINE OPEN DATA96 FOR RANDOM AS #96 ' OPEN CP.prn GET #96, TAGE, TGY CLOSE #96 IF HSYS(L) > 0 THEN IF HSYS(L) < 5 THEN ' CALC CLEARCUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE CUT(L) = VOL(L - 1) * TGY.MBFRATE ELSE ' CALC PARTIAL CUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE * (1 - PERCENTCUT) CUT(L) = VOL(L - 1) * TGY.MBFRATE * (PERCENTCUT) END IF ELSE VOL(L) = VOL(L - 1) * TGY.MBFRATE END IF IF HSYS(L) > 4 THEN ' CALC BA BASAL(L) = BASAL(L - 1) * TGY.BARATE * (1 - PERCENTCUT) ELSE IF HSYS(L) > 0 THEN BASAL(L) = 0 GOTO PORT2 ELSE BASAL(L) = BASAL(L - 1) * TGY.BARATE END IF END IF END IF END IF ' END VOLUME LOOP PORT2: ' BA CODE VERIFIED 8/7/95 NEXT L ' VOLUME CODE VERIFIED 7/19/95 FOR M = 1 TO 10 ' EXPANDING PER-ACRE VALUES TO VOL(M) = VOL(M) * AREA ' STAND-LEVEL VALUES CUT(M) = CUT(M) * AREA NEXT M IF B = 0 THEN ' IF NOT ITERATION 0 TNCUTV.A1 = VOL(1) TNCUTV.A2 = VOL(2) TNCUTV.A3 = VOL(3) TNCUTV.A4 = VOL(4) TNCUTV.A5 = VOL(5) TNCUTV.A6 = VOL(6) TNCUTV.A7 = VOL(7) TNCUTV.A8 = VOL(8) TNCUTV.A9 = VOL(9) TNCUTV.A10 = VOL(10) OPEN DATA18 FOR RANDOM AS #18 ' NO CUT VOLUME FILE - NOCUTVOL.prn PUT #18, UNIT, TNCUTV CLOSE #18 END IF IF B > 0 THEN TBA.B1 = BASAL(1) TBA.B2 = BASAL(2) TBA.B3 = BASAL(3) TBA.B4 = BASAL(4) TBA.B5 = BASAL(5) TBA.B6 = BASAL(6) TBA.B7 = BASAL(7) TBA.B8 = BASAL(8) TBA.B9 = BASAL(9) TBA.B10 = BASAL(10) OPEN DATA14 FOR RANDOM AS #14 ' BASAL AREA FILE - BA.prn PUT #14, UNIT, TBA CLOSE #14 FOR T = 1 TO 10 PCUT(T) = 0 NEXT T TCUT.SP = SPP TCUT.C1 = CUT(1) TCUT.C2 = CUT(2) TCUT.C3 = CUT(3) TCUT.C4 = CUT(4) TCUT.C5 = CUT(5) TCUT.C6 = CUT(6) TCUT.C7 = CUT(7) TCUT.C8 = CUT(8) TCUT.C9 = CUT(9) TCUT.C10 = CUT(10) OPEN DATA16 FOR RANDOM AS #16 ' HARVEST VOLUME FILE - CUT.prn PUT #16, UNIT, TCUT CLOSE #16 IF (B = 1) OR (B MOD 350 = 0) THEN CUTFLAG = 0 FOR G = 1 TO 10 IF CUT(G) > 0 THEN CUTFLAG = 1 NEXT G IF CUTFLAG = 1 THEN PLUSMINUS = 1 PRINT USING " GROWTH - UNIT ##### (###)"; UNIT; SLINK CALL ROADUSE(UCOUNT, LINKS, UNIT, HSYS(), CUT(), PCUT(), PLUSMINUS) SLINK = SLINK + 1 END IF END IF END IF NEXT I COLOR 7, 0 PRINT " Part 1b: Stand Volume and Basal Area Over Time" CLOSE #1 PRINT " Finished Calculating Stand Age, Height, Volume" PRINT " and Basal Area over Time" REM ******************************************************************** REM REM END GROWTH AND YIELD ALGORITHM ' COMPLETED 8/7/95 REM REM ******************************************************************** END SUB SUB INITIAL (NODES, GAP, UCOUNT) REM ******************************************************************** REM REM Generating the initial HARVEST.prn and ROADTYPE.prn files REM and TABUROAD.prn and TABUUNIT.prn files REM NOVEMBER 3, 1995 REM Pete Bettinger REM REM ******************************************************************** COLOR 2, 0 PRINT PRINT "CREATING THE INITIAL FILES " COLOR 7, 0 DIM THARV AS THARVESTC DIM TTABUU AS TTABUUNIT DIM TTABUR AS TTABUROAD DIM TLINK AS TLINKS DIM TUSE AS TROADUSE DIM TGY AS TGROWTH DIM TPOINT AS TCOORD DIM TCOST AS TCOORT DIM TNEW AS TNEWDIST DIM TENTRY AS TENTRYNODE DIM TSTREAM AS TSTREAMUNIT DIM TBADU AS TBADUNIT DIM CC AS STRING DIM DATA1 AS STRING DATA1 = "C:\PETE\THESIS\MODULES\UNITS.PRN" DIM DATA2 AS STRING DATA2 = "C:\PETE\THESIS\MODULES\ROADS.PRN" DIM DATA3 AS STRING DATA3 = "C:\PETE\THESIS\MODULES\STREAMS.PRN" DIM DATA5 AS STRING DATA5 = "C:\PETE\THESIS\MODULES\CW.PRN" DIM DATA6 AS STRING DATA6 = "C:\PETE\THESIS\MODULES\CL.PRN" DIM DATA7 AS STRING DATA7 = "C:\PETE\THESIS\MODULES\CE.PRN" DIM DATA8 AS STRING DATA8 = "C:\PETE\THESIS\MODULES\CD.PRN" DIM DATA9 AS STRING DATA9 = "C:\PETE\THESIS\MODULES\CP.PRN" DIM DATA10 AS STRING DATA10 = "C:\PETE\THESIS\MODULES\HARVEST.PRN" DIM DATA13 AS STRING DATA13 = "C:\PETE\THESIS\MODULES\ROADTYPE.PRN" DIM DATA17 AS STRING DATA17 = "C:\PETE\THESIS\MODULES\ENTRY.PRN" DIM DATA27 AS STRING DATA27 = "C:\PETE\THESIS\MODULES\TABUUNIT.PRN" DIM DATA28 AS STRING DATA28 = "C:\PETE\THESIS\MODULES\TABUROAD.PRN" DIM DATA29 AS STRING DATA29 = "C:\PETE\THESIS\MODULES\STRMUNIT.PRN" DIM DATA34 AS STRING DATA34 = "C:\PETE\THESIS\MODULES\DISTANCE.PRN" DIM DATA36 AS STRING DATA36 = "C:\PETE\THESIS\MODULES\NEWDIST.PRN" DIM DATA41 AS STRING DATA41 = "C:\PETE\THESIS\MODULES\LINKCOST.PRN" DIM DATA42 AS STRING DATA42 = "C:\PETE\THESIS\MODULES\ENTRYRND.PRN" DIM DATA47 AS STRING DATA47 = "C:\PETE\THESIS\MODULES\ROADUSE.PRN" DIM DATA71 AS STRING DATA71 = "C:\PETE\THESIS\MODULES\BADUNIT.PRN" DIM DATA92 AS STRING DATA92 = "C:\PETE\THESIS\MODULES\CWRND.PRN" DIM DATA93 AS STRING DATA93 = "C:\PETE\THESIS\MODULES\CLRND.PRN" DIM DATA94 AS STRING DATA94 = "C:\PETE\THESIS\MODULES\CERND.PRN" DIM DATA95 AS STRING DATA95 = "C:\PETE\THESIS\MODULES\CDRND.PRN" DIM DATA96 AS STRING DATA96 = "C:\PETE\THESIS\MODULES\CPRND.PRN" REM ***************************************************************** REM REM Part 1. Creating HARVEST.PRN and TABUUNIT.PRN REM REM ***************************************************************** PRINT " Creating the initial HARVEST.prn and TABUUNIT.prn files" OPEN DATA1 FOR INPUT AS #1 ' OPEN UNITS.PRN DO WHILE NOT EOF(1) ' WHILE NOT END OF FILE UNITS.PRN INPUT #1, UNIT, AREA, HAZARD, SYS, GEF, SLOPE, SPP, BA, AGE, VOLUME, DISTSTR, RIPAR, AVGK THARV.SILV = 0 THARV.C1 = 0 ' SETTING ALL HARVEST THARV.C2 = 0 ' CHOICES TO 0 THARV.C3 = 0 THARV.C4 = 0 THARV.C5 = 0 THARV.C6 = 0 THARV.C7 = 0 THARV.C8 = 0 THARV.C9 = 0 THARV.C10 = 0 TTABUU.T = 0 ' SET ALL TABU STATES = 0 OPEN DATA10 FOR RANDOM AS #10 ' OPEN HARVEST.PRN PUT #10, UNIT, THARV ' PRINT TO HARVEST.PRN CLOSE #10 OPEN DATA27 FOR RANDOM AS #27 ' OPEN TABUUNIT.PRN PUT #27, UNIT, TTABUU ' PRINT TO TABUUNIT.PRN CLOSE #27 LOOP CLOSE #1 ' CLOSE UNITS.PRN ' VERIFIED 9/12/95 REM ***************************************************************** REM REM Part 2. Creating ROADTYPE.PRN and TABUROAD.PRN REM REM ***************************************************************** PRINT " Creating the initial ROADTYPE.prn and TABUROAD.prn files" LINKS = 0 OPEN DATA2 FOR INPUT AS #2 ' OPEN ROADS.PRN DO WHILE NOT EOF(2) ' WHILE NOT END OF FILE ROADS.PRN LINKS = LINKS + 1 ' COUNTING LINKS INPUT #2, FROMNODE, TONODE, STD, LENGTH, GEF, DISTSTR, INWS, AVGK, RDSLOPE TLINK.S1 = STD TLINK.S2 = STD TLINK.S3 = STD TLINK.S4 = STD TLINK.S5 = STD TLINK.S6 = STD TLINK.S7 = STD TLINK.S8 = STD TLINK.S9 = STD TLINK.S10 = STD OPEN DATA13 FOR RANDOM AS #13 ' OPEN ROADTYPE.PRN PUT #13, LINKS, TLINK CLOSE #13 TTABUR.X = FROMNODE TTABUR.Y = TONODE TTABUR.T = 0 OPEN DATA28 FOR RANDOM AS #28 ' OPEN TABUROAD.PRN PUT #28, LINKS, TTABUR CLOSE #28 TUSE.X = FROMNODE TUSE.Y = TONODE TUSE.U1 = 0 TUSE.U2 = 0 TUSE.U3 = 0 TUSE.U4 = 0 TUSE.U5 = 0 TUSE.U6 = 0 TUSE.U7 = 0 TUSE.U8 = 0 TUSE.U9 = 0 TUSE.U10 = 0 OPEN DATA47 FOR RANDOM AS #47 ' OPEN ROADUSE.PRN PUT #47, LINKS, TUSE CLOSE #47 LOOP CLOSE #2 ' CLOSE ROADS.PRN REM ***************************************************************** REM REM Part 3. Creating DISTANCE.PRN and TABUROAD.PRN REM REM ***************************************************************** PRINT " Creating the DISTANCE.prn and LINKCOST.prn files" COUNT = 0 OPEN DATA2 FOR INPUT AS #2 ' CREATING DISTANCE.PRN OPEN DATA34 FOR RANDOM AS #34 DO WHILE NOT EOF(2) INPUT #2, FROMND, TND, STD, DIST, GEF, DISTSTR, INWS, AVGK, RDSLOPE COUNT = COUNT + 1 TPOINT.X = FROMND TPOINT.Y = TND TPOINT.Z = DIST PUT #34, COUNT, TPOINT COUNT = COUNT + 1 TPOINT.X = TND TPOINT.Y = FROMND TPOINT.Z = DIST PUT #34, COUNT, TPOINT LOOP CLOSE #2 CLOSE #34 OPEN DATA34 FOR RANDOM AS #34 ' SORTING DISTANCE.PRN BY FROM-NODE FOR I = 1 TO (COUNT - 1) GET #34, I, TPOINT A = TPOINT.X B = TPOINT.Y C = TPOINT.Z FOR J = (I + 1) TO COUNT GET #34, J, TPOINT D = TPOINT.X E = TPOINT.Y F = TPOINT.Z IF (D < A) OR (A = D AND E < B) THEN PUT #34, I, TPOINT TPOINT.X = A TPOINT.Y = B TPOINT.Z = C PUT #34, J, TPOINT A = D B = E C = F END IF NEXT J NEXT I CLOSE #34 ' COUNT = (LINKS * 2) OPEN DATA34 FOR RANDOM AS #34 GET #34, 1, TPOINT A = TPOINT.X X = 1 FOR I = 2 TO COUNT GET #34, I, TPOINT B = TPOINT.X IF A = B THEN X = X + 1 ELSE A = B X = 1 END IF IF X > TESTX THEN TESTX = X NEXT I CLOSE #34 X = TESTX OPEN DATA36 FOR RANDOM AS #36 FOR I = 1 TO (NODES * GAP) TNEW.X = 0 TNEW.Y = 0 TNEW.Z = 0 TNEW.SED1 = 0 TNEW.SED2 = 0 TNEW.SED3 = 0 TNEW.SED4 = 0 TNEW.SED5 = 0 TNEW.SED6 = 0 TNEW.SED7 = 0 TNEW.SED8 = 0 TNEW.SED9 = 0 TNEW.SED10 = 0 PUT #36, I, TNEW NEXT I CLOSE #36 'OPEN DATA36 FOR RANDOM AS #36 'FOR I = 1 TO 16 ' GET #36, I, TNEW ' PRINT I, TNEW.X, TNEW.Y ' CC = INPUT$(1) 'NEXT I 'CLOSE #36 OPEN DATA34 FOR RANDOM AS #34 ' CREATING NEWDIST.PRN GET #34, 1, TPOINT CLOSE #34 M = TPOINT.X Y = 1 W = ((M * X) + Y) TNEW.X = TPOINT.X TNEW.Y = TPOINT.Y TNEW.Z = TPOINT.Z TNEW.SED1 = TPOINT.SED1 TNEW.SED2 = TPOINT.SED2 TNEW.SED3 = TPOINT.SED3 TNEW.SED4 = TPOINT.SED4 TNEW.SED5 = TPOINT.SED5 TNEW.SED6 = TPOINT.SED6 TNEW.SED7 = TPOINT.SED7 TNEW.SED8 = TPOINT.SED8 TNEW.SED9 = TPOINT.SED9 TNEW.SED10 = TPOINT.SED10 OPEN DATA36 FOR RANDOM AS #36 PUT #36, W, TNEW CLOSE #36 WW = W FOR I = 2 TO COUNT OPEN DATA34 FOR RANDOM AS #34 ' CREATING NEWDIST.PRN GET #34, I, TPOINT CLOSE #34 N = TPOINT.X IF M = N THEN Y = Y + 1 W = ((M * X) + Y) ELSE M = N Y = 1 W = ((M * X) + Y) END IF IF W <> (WW + 1) THEN FOR R = (WW + 1) TO (W - 1) TNEW.X = 0 TNEW.Y = 0 TNEW.Z = 0 TNEW.SED1 = 0 TNEW.SED2 = 0 TNEW.SED3 = 0 TNEW.SED4 = 0 TNEW.SED5 = 0 TNEW.SED6 = 0 TNEW.SED7 = 0 TNEW.SED8 = 0 TNEW.SED9 = 0 TNEW.SED10 = 0 OPEN DATA36 FOR RANDOM AS #36 PUT #36, R, TNEW CLOSE #36 NEXT R END IF TNEW.X = TPOINT.X TNEW.Y = TPOINT.Y TNEW.Z = TPOINT.Z TNEW.SED1 = TPOINT.SED1 TNEW.SED2 = TPOINT.SED2 TNEW.SED3 = TPOINT.SED3 TNEW.SED4 = TPOINT.SED4 TNEW.SED5 = TPOINT.SED5 TNEW.SED6 = TPOINT.SED6 TNEW.SED7 = TPOINT.SED7 TNEW.SED8 = TPOINT.SED8 TNEW.SED9 = TPOINT.SED9 TNEW.SED10 = TPOINT.SED10 OPEN DATA36 FOR RANDOM AS #36 PUT #36, W, TNEW CLOSE #36 WW = W NEXT I GAP = X ' VERIFIED 11/12/95 I = 0 OPEN DATA36 FOR RANDOM AS #36 ' MIRRORING NEWDIST.PRN DO WHILE NOT EOF(36) ' BY FROM- AND TO-NODES I = I + 1 GET #36, I, TNEW TCOST.Q = TNEW.X TCOST.W = TNEW.Y OPEN DATA41 FOR RANDOM AS #41 ' CREATING LINKCOST.PRN PUT #41, I, TCOST CLOSE #41 LOOP CLOSE #36 REM ***************************************************************** REM REM Part 4. Creating Growth and Yield Files REM REM ***************************************************************** PRINT " Creating the Growth and Yield files" OPEN DATA5 FOR INPUT AS #5 OPEN DATA92 FOR RANDOM AS #92 FOR I = 1 TO 30 INPUT #5, AGE, TPA, BA, BARATE, MBF, MBFRATE, HT, HTRATE TGY.AGE = AGE TGY.TPA = TPA TGY.BA = BA TGY.BARATE = BARATE TGY.MBF = MBF TGY.MBFRATE = MBFRATE TGY.HT = HT TGY.HTRATE = HTRATE PUT #92, I, TGY NEXT I CLOSE #5 CLOSE #92 OPEN DATA6 FOR INPUT AS #6 OPEN DATA93 FOR RANDOM AS #93 FOR I = 1 TO 30 INPUT #6, AGE, TPA, BA, BARATE, MBF, MBFRATE, HT, HTRATE TGY.AGE = AGE TGY.TPA = TPA TGY.BA = BA TGY.BARATE = BARATE TGY.MBF = MBF TGY.MBFRATE = MBFRATE TGY.HT = HT TGY.HTRATE = HTRATE PUT #93, I, TGY NEXT I CLOSE #6 CLOSE #93 OPEN DATA7 FOR INPUT AS #7 OPEN DATA94 FOR RANDOM AS #94 FOR I = 1 TO 30 INPUT #7, AGE, TPA, BA, BARATE, MBF, MBFRATE, HT, HTRATE TGY.AGE = AGE TGY.TPA = TPA TGY.BA = BA TGY.BARATE = BARATE TGY.MBF = MBF TGY.MBFRATE = MBFRATE TGY.HT = HT TGY.HTRATE = HTRATE PUT #94, I, TGY NEXT I CLOSE #7 CLOSE #94 OPEN DATA8 FOR INPUT AS #8 OPEN DATA95 FOR RANDOM AS #95 FOR I = 1 TO 30 INPUT #8, AGE, TPA, BA, BARATE, MBF, MBFRATE, HT, HTRATE TGY.AGE = AGE TGY.TPA = TPA TGY.BA = BA TGY.BARATE = BARATE TGY.MBF = MBF TGY.MBFRATE = MBFRATE TGY.HT = HT TGY.HTRATE = HTRATE PUT #95, I, TGY NEXT I CLOSE #8 CLOSE #95 OPEN DATA9 FOR INPUT AS #9 OPEN DATA96 FOR RANDOM AS #96 FOR I = 1 TO 30 INPUT #9, AGE, TPA, BA, BARATE, MBF, MBFRATE, HT, HTRATE TGY.AGE = AGE TGY.TPA = TPA TGY.BA = BA TGY.BARATE = BARATE TGY.MBF = MBF TGY.MBFRATE = MBFRATE TGY.HT = HT TGY.HTRATE = HTRATE PUT #96, I, TGY NEXT I CLOSE #9 CLOSE #96 REM ***************************************************************** REM REM Part 5. Creating Entry Node Random Access File REM REM ***************************************************************** PRINT " Creating the Entry Node Random Access File" OPEN DATA17 FOR INPUT AS #17 ' CREATING ENTRYRND.prn OPEN DATA42 FOR RANDOM AS #42 ' A RANDOM ACCESS FILE FOR ENTRY DO WHILE NOT EOF(17) ' NODES INPUT #17, UNIT, SYS, ENNODE TENTRY.X = UNIT TENTRY.S = SYS TENTRY.E = ENNODE W = (((SYS - 1) * UCOUNT) + UNIT) PUT #42, W, TENTRY LOOP CLOSE #17 CLOSE #42 REM ***************************************************************** REM REM Part 6. Creating Stream-Unit Random Access File REM REM ***************************************************************** PRINT " Creating Stream-Unit Random Access File" OPEN DATA29 FOR RANDOM AS #29 FOR I = 2 TO UCOUNT TSTREAM.U = 0 PUT #29, I, TSTREAM NEXT I CLOSE #29 OPEN DATA3 FOR INPUT AS #3 OPEN DATA29 FOR RANDOM AS #29 DO WHILE NOT EOF(3) INPUT #3, UPSTRM, DNSTRM, CLASS, STRMLN, STRMORIENT, POLY, SLOPE, TREECHDIST, SHADEDENSITY, OVERHANG TSTREAM.U = 1 PUT #29, POLY, TSTREAM LOOP CLOSE #3 CLOSE #29 REM ***************************************************************** REM REM Part 7. Creating BADUNIT Random Access File REM REM ***************************************************************** PRINT " Creating BADUNIT Random Access File" OPEN DATA1 FOR INPUT AS #1 OPEN DATA71 FOR RANDOM AS #71 DO WHILE NOT EOF(1) INPUT #1, UNIT, AREA, HAZ, SYS, GEF, SLOPE, SPP, BA, AGE, VOL, DISTSTR, RIPAR, AVGK TBADU.U = 0 PUT #71, UNIT, TBADU LOOP CLOSE #1 CLOSE #71 REM ******************************************************************** REM REM END - Generating the initial HARVEST.prn and ROADTYPE.prn files REM REM ******************************************************************** END SUB SUB MINGROWTH REM ************************************************************** REM REM Growth and Yield Sub-Algorithm REM November 6, 1995 REM REM PETE BETTINGER REM REM This algorithm determines stand volume and basal area, REM from stand age and plant association - FOR A CANDIDATE UNIT REM CHOICE ONLY. REM REM Wallowa-Whitman National Forest. 1994. Growth tables derived from REM prognosis. Wallowa-Whitman National Forest, La Grande, OR. REM REM ************************************************************** REM COMMENTS: REM 1. Part 1 - Determining Stand Age and Volume Over Time REM 2. Part 1a - Stand Ages and Heights REM 3. Part 1b - Stand Volume and Basal Area (VOL() and CUT() REM are total MBF values, not per-acre values) REM REM 4. REMEMBER TO CREATE OTHER GROWTH FILES, AND CHANGE THEIR REM NAMES IN THE DECLARATIONS BELOW REM REM ************************************************************** COLOR 2, 0 PRINT PRINT "STAND GROWTH ALGORITHM - CANDIDATE UNIT CHOICES" COLOR 7, 0 DIM TGY AS TGROWTH DIM DATA1 AS STRING ' DATA FILE FOR UNITS DATA1 = "C:\PETE\THESIS\MODULES\UNITS.PRN" DIM DATA22 AS STRING ' DATA FILE CANDIDAT.PRN DATA22 = "C:\PETE\THESIS\MODULES\CANDIDAT.PRN" DIM DATA23 AS STRING ' DATA FILE TEMPBA.prn DATA23 = "C:\PETE\THESIS\MODULES\TEMPBA.PRN" DIM DATA24 AS STRING ' DATA FILE TEMPHT.prn DATA24 = "C:\PETE\THESIS\MODULES\TEMPHT.PRN" DIM DATA25 AS STRING ' DATA FILE TEMPCUT.prn DATA25 = "C:\PETE\THESIS\MODULES\TEMPCUT.PRN" DIM DATA92 AS STRING ' DATA FILE CW.prn DATA92 = "C:\PETE\THESIS\MODULES\CWRND.PRN" DIM DATA93 AS STRING ' DATA FILE CL.prn DATA93 = "C:\PETE\THESIS\MODULES\CLRND.PRN" DIM DATA94 AS STRING ' DATA FILE CE.prn DATA94 = "C:\PETE\THESIS\MODULES\CERND.PRN" DIM DATA95 AS STRING ' DATA FILE CD.prn DATA95 = "C:\PETE\THESIS\MODULES\CDRND.PRN" DIM DATA96 AS STRING ' DATA FILE CP.prn DATA96 = "C:\PETE\THESIS\MODULES\CPRND.PRN" DIM CC AS STRING ' STRING TO PAUSE RUNNING OF PROGRAM DIM COUNT AS SINGLE ' USED IN PART 1, NUMBER OF UNITS DIM UNIT AS SINGLE ' USED IN PART 1, UNIT NUMBER DIM AREA AS SINGLE ' USED IN PART 1, UNIT AREA DIM HAZARD AS SINGLE ' USED IN PART 1, EROSION HAZARD RATING DIM SYS AS SINGLE ' USED IN PART 1, LOGGING SYSTEM DIM SLOPE AS SINGLE ' USED IN PART 1, GROUND SLOPE DIM GEFACTOR AS SINGLE ' USED IN PART 1, GEOLOGIC EROSION FACTOR DIM SPP AS SINGLE ' USED IN PART 1, PLANT ASSOCIATION (SPECIES) DIM BA AS SINGLE ' USED IN PART 1, BASAL AREA PER ACRE DIM AGE AS SINGLE ' USED IN PART 1a, STAND AGE DIM VOLUME AS SINGLE ' USED IN PART 1a, STAND VOLUME PER ACRE DIM UNIT2 AS SINGLE ' USED IN PART 1a, UNIT NUMBER DIM HSYS(10) AS SINGLE ' USED IN PART 1a, HARVEST TYPE FOR UNIT I DIM SAGE(10) AS SINGLE ' USED IN PART 1a, AGE FOR UNIT I DIM HEIGHT(10) AS SINGLE ' USED IN PART 1a, TREE HEIGHTS DIM VOL(10) AS SINGLE ' USED IN PART 1b, STAND VOLUME FOR UNIT I DIM CUT(10) AS SINGLE ' USED IN PART 1b, STAND HARVEST FOR UNIT I DIM BASAL(10) AS SINGLE ' USED IN PART 1b, BASAL AREA FOR UNIT I DIM TOOT AS SINGLE ' USED IN PART 1b, A FLAG FOR CLEARCUTTING DIM BA1 AS SINGLE ' USED IN PART 1b, BASAL AREA PER ACRE DIM BA2 AS SINGLE ' USED IN PART 1b, BASAL AREA PER ACRE DIM AGE1 AS SINGLE ' USED IN PART 1b, STAND AGE DIM AGE2 AS SINGLE ' USED IN PART 1b, STAND AGE DIM TPA1 AS SINGLE ' USED IN PART 1b, TREES PER ACRE DIM TPA2 AS SINGLE ' USED IN PART 1b, TREES PER ACRE DIM MMBF1 AS SINGLE ' USED IN PART 1b, VOLUME PER ACRE DIM MMBF2 AS SINGLE ' USED IN PART 1b, VOLUME PER ACRE DIM RATE1 AS SINGLE ' USED IN PART 1b, GROWTH RATE DIM RATE2 AS SINGLE ' USED IN PART 1b, GROWTH RATE DIM PERCENTCUT AS SINGLE ' USED IN PART 1b, PARTIAL CUT PERCENT PERCENTCUT = .33 ' PERCENT OF STAND CUT IN PARTIAL CUT REM ****************************************************** REM Part 1. Determining Stand Age and Volume Over Time REM ****************************************************** PRINT " Part 1: Stand Age and Volume Over Time - CANDIDATE" OPEN DATA1 FOR INPUT AS #1 ' UNITS FILE - UNITS.prn OPEN DATA22 FOR INPUT AS #22 ' CANDIDATE FILE - CANDIDAT.prn OPEN DATA23 FOR OUTPUT AS #23 ' BASAL AREA FILE - TEMPBA.prn OPEN DATA24 FOR OUTPUT AS #24 ' TREE HEIGHT FILE - TEMPHT.prn OPEN DATA25 FOR OUTPUT AS #25 ' HARVEST VOLUME FILE - TEMPCUT.prn REM *********************************************************** REM Part 1a. Determining Stand Ages and Heights Over Time REM *********************************************************** FOR I = 1 TO 1 ' FOR THE CANDIDATE TOOT = 0 INPUT #22, UNIT2, SILV2 DOAGAIN: INPUT #1, UNIT, AREA, HAZARD, SYS, GEFACTOR, SLOPE, SPP, BA, AGE, VOLUME, DISTSTR, RIPAR, AVGK IF UNIT <> UNIT2 THEN GOTO DOAGAIN FOR J = 1 TO 10 ' INPUT HARVEST TYPE BY PERIOD J INPUT #22, HSYS(J) ' FOR UNIT I NEXT J ' VERIFIED 7/17/95 SAGE(0) = AGE FOR K = 1 TO 10 ' FOR EACH PERIOD - AGE AT MIDPT. CUT(K) = 0 ' CUT = 0 IF HSYS(K - 1) > 0 AND HSYS(K - 1) < 5 THEN ' IF CC IN (t-1) SAGE(K) = 10 ' AGE AT t IS 10 ELSE SAGE(K) = 10 + SAGE(K - 1) ' ELSE AGE t = 10 + AGE END IF ' (t-1) IF HSYS(K) > 0 AND HSYS(K) < 5 THEN ' IF CC IN t, HEIGHT = 0 HEIGHT(K) = 0 ELSE RAGE = INT(SAGE(K) / 10) ' ELSE, CALCULATE HEIGHT IF RAGE = 0 THEN RAGE = 1 IF RAGE > 30 THEN RAGE = 30 IF SPP = 1 THEN HEIGHT(K) = 0 IF SPP = 2 THEN OPEN DATA92 FOR RANDOM AS #92 GET #92, RAGE, TGY CLOSE #92 HEIGHT(K) = TGY.HT ELSEIF SPP = 3 THEN OPEN DATA93 FOR RANDOM AS #93 GET #93, RAGE, TGY CLOSE #93 HEIGHT(K) = TGY.HT ELSEIF SPP = 4 THEN OPEN DATA94 FOR RANDOM AS #94 GET #94, RAGE, TGY CLOSE #94 HEIGHT(K) = TGY.HT ELSEIF SPP = 5 THEN OPEN DATA95 FOR RANDOM AS #95 GET #95, RAGE, TGY CLOSE #95 HEIGHT(K) = TGY.HT ELSEIF SPP = 6 THEN OPEN DATA96 FOR RANDOM AS #96 GET #96, RAGE, TGY CLOSE #96 HEIGHT(K) = TGY.HT END IF END IF ' HEIGHT CODE VERIFIED 8/7/95 NEXT K ' AGES CODE VERIFIED 7/18/95 PRINT #24, UNIT; HEIGHT(1); HEIGHT(2); HEIGHT(3); HEIGHT(4); HEIGHT(5); HEIGHT(6); HEIGHT(7); HEIGHT(8); HEIGHT(9); HEIGHT(10) REM *************************************************************** REM Part 1b. Determining Stand Volume and Basal Area Over Time REM *************************************************************** TOOT = 0 VOL(0) = VOLUME ' INITIAL VOLUME BASAL(0) = BA ' INITIAL BASAL AREA FOR L = 1 TO 10 ' FOR EACH PERIOD IF HSYS(L - 1) > 0 AND HSYS(L - 1) < 5 THEN TOOT = 1 IF HSYS(L) > 0 THEN TOOT = 0 IF TOOT = 1 THEN ' IF CC IN (t-1) OR PREVIOUS ' PERIOD t TAGE = INT(SAGE(L) / 10) ' VOLUME AND BASAL AREA IF TAGE < .1 THEN TAGE = 1 IF SPP = 2 THEN ' ARE FROM THE GROWTH AND OPEN DATA92 FOR RANDOM AS #92 ' YIELD TABLES FOR A GET #92, TAGE, TGY ' REGULATED FOREST CLOSE #92 ELSEIF SPP = 3 THEN OPEN DATA93 FOR RANDOM AS #93 GET #93, TAGE, TGY CLOSE #93 ELSEIF SPP = 4 THEN OPEN DATA94 FOR RANDOM AS #94 GET #94, TAGE, TGY CLOSE #94 ELSEIF SPP = 5 THEN OPEN DATA95 FOR RANDOM AS #95 GET #95, TAGE, TGY CLOSE #95 ELSEIF SPP = 6 THEN OPEN DATA96 FOR RANDOM AS #96 GET #96, TAGE, TGY CLOSE #96 END IF BASAL(L) = TGY.BA ' BASAL AREA, REGULATED FOREST VOL(L) = TGY.MBF ELSE ' IF NOT CLEARCUT IN (t-1) TAGE = INT(SAGE(L) / 10) IF TAGE = 0 OR TAGE = -1 THEN TAGE = 1 IF SPP = 1 THEN ' IF MEADOW VOL(L) = VOL(L - 1) BASAL(L) = BASAL(L - 1) ELSEIF SPP = 2 THEN ' IF GRAND FIR OPEN DATA92 FOR RANDOM AS #92 ' OPEN CW.prn GET #92, TAGE, TGY CLOSE #92 IF HSYS(L) > 0 THEN IF HSYS(L) < 5 THEN ' CALC CLEARCUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE CUT(L) = VOL(L - 1) * TGY.MBFRATE ELSE ' CALC PARTIAL CUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE * (1 - PERCENTCUT) CUT(L) = VOL(L - 1) * TGY.MBFRATE * (PERCENTCUT) END IF ELSE VOL(L) = VOL(L - 1) * TGY.MBFRATE END IF IF HSYS(L) > 4 THEN ' CALC BA BASAL(L) = BASAL(L - 1) * TGY.BARATE * (1 - PERCENTCUT) ELSE IF HSYS(L) > 0 THEN BASAL(L) = 0 GOTO PORT22 ELSE BASAL(L) = BASAL(L - 1) * TGY.BARATE END IF END IF ELSEIF SPP = 3 THEN ' IF LODGEPOLE PINE OPEN DATA93 FOR RANDOM AS #93 ' OPEN CL.prn GET #93, TAGE, TGY CLOSE #93 IF HSYS(L) > 0 THEN IF HSYS(L) < 5 THEN ' CALC CLEARCUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE CUT(L) = VOL(L - 1) * TGY.MBFRATE ELSE ' CALC PARTIAL CUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE * (1 - PERCENTCUT) CUT(L) = VOL(L - 1) * TGY.MBFRATE * (PERCENTCUT) END IF ELSE VOL(L) = VOL(L - 1) * TGY.MBFRATE END IF IF HSYS(L) > 4 THEN ' CALC BA BASAL(L) = BASAL(L - 1) * TGY.BARATE * (1 - PERCENTCUT) ELSE IF HSYS(L) > 0 THEN BASAL(L) = 0 GOTO PORT22 ELSE BASAL(L) = BASAL(L - 1) * TGY.BARATE END IF END IF ELSEIF SPP = 4 THEN ' IF SUBALPINE FIR OPEN DATA94 FOR RANDOM AS #94 ' OPEN CE.prn GET #94, TAGE, TGY CLOSE #94 IF HSYS(L) > 0 THEN IF HSYS(L) < 5 THEN ' CALC CLEARCUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE CUT(L) = VOL(L - 1) * TGY.MBFRATE ELSE ' CALC PARTIAL CUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE * (1 - PERCENTCUT) CUT(L) = VOL(L - 1) * TGY.MBFRATE * (PERCENTCUT) END IF ELSE VOL(L) = VOL(L - 1) * TGY.MBFRATE END IF IF HSYS(L) > 4 THEN ' CALC BA BASAL(L) = BASAL(L - 1) * TGY.BARATE * (1 - PERCENTCUT) ELSE IF HSYS(L) > 0 THEN BASAL(L) = 0 GOTO PORT22 ELSE BASAL(L) = BASAL(L - 1) * TGY.BARATE END IF END IF ELSEIF SPP = 5 THEN ' IF DOUGLAS-FIR OPEN DATA95 FOR RANDOM AS #95 ' OPEN CD.prn GET #95, TAGE, TGY CLOSE #95 IF HSYS(L) > 0 THEN IF HSYS(L) < 5 THEN ' CALC CLEARCUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE CUT(L) = VOL(L - 1) * TGY.MBFRATE ELSE ' CALC PARTIAL CUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE * (1 - PERCENTCUT) CUT(L) = VOL(L - 1) * TGY.MBFRATE * (PERCENTCUT) END IF ELSE VOL(L) = VOL(L - 1) * TGY.MBFRATE END IF IF HSYS(L) > 4 THEN ' CALC BA BASAL(L) = BASAL(L - 1) * TGY.BARATE * (1 - PERCENTCUT) ELSE IF HSYS(L) > 0 THEN BASAL(L) = 0 GOTO PORT22 ELSE BASAL(L) = BASAL(L - 1) * TGY.BARATE END IF END IF ELSEIF SPP = 6 THEN ' IF PONDEROSA PINE OPEN DATA96 FOR RANDOM AS #96 ' OPEN CP.prn GET #96, TAGE, TGY CLOSE #96 IF HSYS(L) > 0 THEN IF HSYS(L) < 5 THEN ' CALC CLEARCUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE CUT(L) = VOL(L - 1) * TGY.MBFRATE ELSE ' CALC PARTIAL CUT VOLUME VOL(L) = VOL(L - 1) * TGY.MBFRATE * (1 - PERCENTCUT) CUT(L) = VOL(L - 1) * TGY.MBFRATE * (PERCENTCUT) END IF ELSE VOL(L) = VOL(L - 1) * TGY.MBFRATE END IF IF HSYS(L) > 4 THEN ' CALC BA BASAL(L) = BASAL(L - 1) * TGY.BARATE * (1 - PERCENTCUT) ELSE IF HSYS(L) > 0 THEN BASAL(L) = 0 GOTO PORT22 ELSE BASAL(L) = BASAL(L - 1) * TGY.BARATE END IF END IF END IF END IF ' END VOLUME LOOP PORT22: ' BA CODE VERIFIED 8/7/95 NEXT L ' VOLUME CODE VERIFIED 7/19/95 FOR M = 1 TO 10 VOL(M) = VOL(M) * AREA CUT(M) = CUT(M) * AREA NEXT M PRINT #23, UNIT; BASAL(1); BASAL(2); BASAL(3); BASAL(4); BASAL(5); BASAL(6); BASAL(7); BASAL(8); BASAL(9); BASAL(10) PRINT #25, UNIT; SPP; CUT(1); CUT(2); CUT(3); CUT(4); CUT(5); CUT(6); CUT(7); CUT(8); CUT(9); CUT(10) NEXT I COLOR 7, 0 PRINT " Part 1b: Stand Volume and Basal Area Over Time - CANDIDATE" CLOSE #1 CLOSE #22 CLOSE #23 CLOSE #24 CLOSE #25 PRINT " Finished Calculating Stand Age, Height, Volume" PRINT " and Basal Area over Time - FOR THE CANDIDATE" REM ******************************************************************** REM REM END GROWTH AND YIELD ALGORITHM ' COMPLETED 8/7/95 REM REM ******************************************************************** END SUB SUB NEIGHBOR (PV, BS, UCOUNT, NODES, CT(), BESTNPV) ' PV = CURRENT NET PRESENT VALUE, ' BS = UNIT FLAG, UCOUNT = UNITS, NODES = NODES REM ****************************************************************** REM REM Neighborhood Algorithm REM DECEMBER 10, 1995 REM Pete Bettinger REM REM This algorithm determines the neighborhood for Units REM REM ****************************************************************** COLOR 2, 0 PRINT PRINT "NEIGHBORHOOD ALGORITHM" COLOR 7, 0 DIM TENTRY AS TENTRYNODE DIM TMNTCOST AS TMAINTCOST DIM TCUT AS TCUTVOL DIM TGY AS TGROWTH DIM TNCUTA AS TNOCUTAGE DIM TNCUTV AS TNOCUTVOL DIM THCST AS TUNITHAULCOST DIM TREVNU AS TUNITREVENUE DIM TINSOL AS TINSOLUTION DIM TTABUU AS TTABUUNIT DIM TBADU AS TBADUNIT DIM DATA1 AS STRING ' DATA FILE UNITS.PRN DATA1 = "C:\PETE\THESIS\MODULES\UNITS.PRN" DIM DATA16 AS STRING ' DATA FILE CUT.prn DATA16 = "C:\PETE\THESIS\MODULES\CUT.PRN" DIM DATA18 AS STRING ' DATA FILE NOCUTVOL.prn DATA18 = "C:\PETE\THESIS\MODULES\NOCUTVOL.PRN" DIM DATA19 AS STRING ' DATA FILE REGIMES.prn DATA19 = "C:\PETE\THESIS\MODULES\REGIMES.PRN" DIM DATA20 AS STRING ' DATA FILE NOCUTAGE.PRN DATA20 = "C:\PETE\THESIS\MODULES\NOCUTAGE.PRN" DIM DATA21 AS STRING ' DATA FILE UNITNPV.PRN DATA21 = "C:\PETE\THESIS\MODULES\UNITNPV.PRN" DIM DATA27 AS STRING ' DATA FILE TABUUNIT.PRN DATA27 = "C:\PETE\THESIS\MODULES\TABUUNIT.PRN" DIM DATA37 AS STRING ' DATA FILE REVENUE.PRN DATA37 = "C:\PETE\THESIS\MODULES\REVENUE.PRN" DIM DATA38 AS STRING ' DATA FILE HAULCOST.PRN DATA38 = "C:\PETE\THESIS\MODULES\HAULCOST.PRN" DIM DATA40 AS STRING DATA40 = "C:\PETE\THESIS\MODULES\MNTCOST.PRN" DIM DATA42 AS STRING DATA42 = "C:\PETE\THESIS\MODULES\ENTRYRND.PRN" DIM DATA45 AS STRING DATA45 = "C:\PETE\THESIS\MODULES\INSOL.PRN" DIM DATA71 AS STRING DATA71 = "C:\PETE\THESIS\MODULES\BADUNIT.PRN" DIM DATA92 AS STRING ' GRAND FIR DATA92 = "C:\PETE\THESIS\MODULES\CWRND.PRN" DIM DATA93 AS STRING ' LODGEPOLE PINE DATA93 = "C:\PETE\THESIS\MODULES\CLRND.PRN" DIM DATA94 AS STRING ' SUBALPINE FIR DATA94 = "C:\PETE\THESIS\MODULES\CERND.PRN" DIM DATA95 AS STRING ' DOUGLAS-FIR DATA95 = "C:\PETE\THESIS\MODULES\CDRND.PRN" DIM DATA96 AS STRING ' PONDEROSA PINE DATA96 = "C:\PETE\THESIS\MODULES\CPRND.PRN" DIM CUT(10) AS SINGLE ' HARVEST (MBF) FOR I = 1 TO 10 ' SETTING ALL TO 0 BEFORE READING THEM CUT(I) = 0 NEXT I DIM CC AS STRING ' USED TO BREAK THE PROGRAM DIM UNIT AS SINGLE ' USED IN PART 1, UNIT NUMBER DIM SPP AS SINGLE ' USED IN PART 1, SPECIES DIM HARVEST(10) AS SINGLE ' USED IN PART 1, HARVEST VOLUME (MBF) DIM TOTFLOW AS SINGLE ' USED IN PART 1, TOTAL OF EVENFLOW DIM UNITAGE(10) AS SINGLE ' USED IN PART 1, UNIT AGE OVER TIME DIM UNITCUT(10) AS SINGLE ' USED IN PART 1, UNIT VOLUME OVER TIME DIM UNITVOL(10) AS SINGLE ' USED IN PART 1, UNIT VOLUME - NO CUT DIM EF(10) AS SINGLE ' USED IN PART 1, CANDIDATE VALUES DIM PERIOD AS SINGLE ' USED IN PART 1, PERIOD OF HARVEST DIM PER AS SINGLE ' USED IN PART 1, PERIOD DIM AREA AS SINGLE ' USED IN PART 1, UNIT AREA DIM XX AS SINGLE ' USED IN PART 1, FOR-NEXT VARIABLE DIM VOLUME(19) AS SINGLE ' USED IN PART 1, UNIT VOLUME DIM STANDAGE(19) AS SINGLE ' USED IN PART 1, UNIT AGE DIM SYS AS SINGLE ' USED IN PART 1, HARVEST SYSTEM DIM ENNODE AS SINGLE ' USED IN PART 1, UNIT ENTRY NODE DIM PMCOST(19) AS SINGLE ' USED IN PART 1, POTENTIAL MAINT COST DIM LCPERIOD AS SINGLE ' USED IN PART 1, PERIOD WITH LOWEST CUT DIM HCPERIOD AS SINGLE ' USED IN PART 1, PERIOD WITH HIGHEST CUT DIM TEMPCUT1 AS SINGLE ' USED IN PART 1, TEMPORARY VARIABLE DIM TEMPCUT2 AS SINGLE ' USED IN PART 1, TEMPORARY VARIABLE DIM C(19) AS SINGLE ' USED IN PART 1, TEMPORARY VARIABLE DIM VOL(19) AS SINGLE ' USED IN PART 1, TEMPORARY VARIABLE DIM LEFT(19) AS SINGLE ' USED IN PART 1, TEMPORARY VARIABLE DIM HAULCOST(10) AS SINGLE ' USED IN PART 1, HAUL COST DIM RATE(40, 6) AS SINGLE ' USED IN PART 1, MBF GROWTH RATES DIM MBFVOL(40, 6) AS SINGLE ' USED IN PART 1, MBF DIM STUMPAGE(6) AS SINGLE ' STUMPAGE VALUES STUMPAGE(1) = 0 ' SPECIES 1 = $0/MBF STUMPAGE(2) = 355 ' SPECIES 2 = $355/MBF STUMPAGE(3) = 377 ' ETC. STUMPAGE(4) = 355 STUMPAGE(5) = 433 STUMPAGE(6) = 433 DIM LOGCOST(8) AS SINGLE ' LOGGING COSTS LOGCOST(1) = 99.5 ' GROUND-BASED LOGCOST(2) = 114.61 ' CABLE - JAMMER LOGCOST(3) = 151.5 ' CABLE - SKYLINE LOGCOST(4) = 375 ' HELICOPTER LOGCOST(5) = 99.5 ' GROUND-BASED LOGCOST(6) = 114.61 ' CABLE - JAMMER LOGCOST(7) = 151.5 ' CABLE - SKYLINE LOGCOST(8) = 375 ' HELICOPTER DIM PERCENTCUT(10) AS SINGLE ' PERCENT CUT FROM EXISTING STAND FOR I = 1 TO 4 PERCENTCUT(I) = 1 ' CLEARCUT SYSTEMS 1-4 NEXT I FOR I = 5 TO 8 PERCENTCUT(I) = .33 ' PARTIAL CUT SYSTEMS 5-8 NEXT I REM ****************************************************** REM REM Part 0. Determining Current Even-Flow Levels REM REM ****************************************************** PRINT " Determining Current Even-Flow Levels" FOR I = 1 TO 10 CUT(I) = 0 NEXT I IF BS > 0 THEN ' IF NOT UNSCHEDULING OPEN DATA16 FOR RANDOM AS #16 ' DETERMINING THE HARVEST FOR I = 2 TO UCOUNT ' LEVEL PER PERIOD GET #16, I, TCUT ' THIS IS USED TO CALCULATE CUT(1) = CUT(1) + TCUT.C1 ' EVEN-FLOW LEVELS CUT(2) = CUT(2) + TCUT.C2 CUT(3) = CUT(3) + TCUT.C3 CUT(4) = CUT(4) + TCUT.C4 CUT(5) = CUT(5) + TCUT.C5 CUT(6) = CUT(6) + TCUT.C6 CUT(7) = CUT(7) + TCUT.C7 CUT(8) = CUT(8) + TCUT.C8 CUT(9) = CUT(9) + TCUT.C9 CUT(10) = CUT(10) + TCUT.C10 NEXT I ' VERIFIED 8/29/95 CLOSE #16 TEMPCUT2 = 99999999 TEMPCUT = -1 FOR I = 1 TO 10 IF CUT(I) > TEMPCUT1 THEN ' LOCATING PERIOD WITH TEMPCUT1 = CUT(I) ' HIGHEST VOLUME CUT HCPERIOD = I END IF IF CUT(I) < TEMPCUT2 THEN ' LOCATING PERIOD WITH TEMPCUT2 = CUT(I) ' LOWEST VOLUME CUT LCPERIOD = I ' LCPERIOD = period of interest END IF ' VERIFIED 9/7/95 NEXT I TOTFLOW = 0 FOR K = 1 TO 10 ' CALCULATING THE TOTAL CUT TOTFLOW = TOTFLOW + CUT(K) NEXT K ' VERIFIED 8/29/95 PRINT FOR K = 1 TO 10 PRINT USING " Current Harvest, Period ## = ###,###,###.# MBF"; K; CUT(K) CT(K) = CUT(K) NEXT K PRINT PRINT USING " Period ##, had lowest volume cut ###,###,###.## MBF"; LCPERIOD; TEMPCUT2 PRINT USING " Period ##, had highest volume cut ###,###,###.## MBF"; HCPERIOD; TEMPCUT1 PRINT ELSE LCPERIOD = 0 END IF REM ****************************************************** REM REM Part 1. Developing Unit Neighborhood REM REM ****************************************************** PRINT " Developing Unit Neighborhood" FOR I = 1 TO 16 ' only need 15, because after age 150, OPEN DATA92 FOR RANDOM AS #92 GET #92, I, TGY ' stands can't be cut, so no need to CLOSE #92 RATE(I, 2) = TGY.MBFRATE ' growth them beyond 150 in NEIGHBOR MBFVOL(I, 2) = TGY.MBF OPEN DATA93 FOR RANDOM AS #93 GET #93, I, TGY CLOSE #93 RATE(I, 3) = TGY.MBFRATE MBFVOL(I, 3) = TGY.MBF OPEN DATA94 FOR RANDOM AS #94 GET #94, I, TGY CLOSE #94 RATE(I, 4) = TGY.MBFRATE MBFVOL(I, 4) = TGY.MBF OPEN DATA95 FOR RANDOM AS #95 GET #95, I, TGY CLOSE #95 RATE(I, 5) = TGY.MBFRATE MBFVOL(I, 5) = TGY.MBF OPEN DATA96 FOR RANDOM AS #96 GET #96, I, TGY CLOSE #96 RATE(I, 6) = TGY.MBFRATE MBFVOL(I, 6) = TGY.MBF NEXT I ' VERIFIED 10/10/95 OPEN DATA19 FOR OUTPUT AS #19 ' OPEN REGIMES.prn OPEN DATA21 FOR OUTPUT AS #21 ' OPEN UNITNPV.prn OPEN DATA1 FOR INPUT AS #1 ' OPEN UNITS.prn ACCODE = RND IF ACCODE < .006 THEN SANANTONE = 0 AMARILLO = .999999 ELSEIF ACCODE > .0059 AND ACCODE < .337 THEN SANANTONE = 1 AMARILLO = 4.999999 ELSEIF ACCODE > .33699 AND ACCODE < .668 THEN SANANTONE = 5 AMARILLO = 10.999999# ELSE SANANTONE = 11 AMARILLO = 500 END IF DO WHILE NOT EOF(1) ' FOR EACH UNIT FRONTIER: INPUT #1, UNIT, AREA, HAZARD, LSYS, GEF, SLOPE, SPP, BA, AGE, VOL, DISTSTR, RIPAR, AVGK IF AREA < SANANTONE OR AREA > AMARILLO THEN GOTO BUCKINGHAM ' PARING DOWN THE LIST OPEN DATA18 FOR RANDOM AS #18 ' OPEN NOCUTVOL.prn GET #18, UNIT, TNCUTV ' INPUT NO-CUT VOLUME CLOSE #18 VOLUME(1) = TNCUTV.A1 VOLUME(2) = TNCUTV.A2 VOLUME(3) = TNCUTV.A3 VOLUME(4) = TNCUTV.A4 VOLUME(5) = TNCUTV.A5 VOLUME(6) = TNCUTV.A6 VOLUME(7) = TNCUTV.A7 VOLUME(8) = TNCUTV.A8 VOLUME(9) = TNCUTV.A9 VOLUME(10) = TNCUTV.A10 OPEN DATA20 FOR RANDOM AS #20 ' OPEN NOCUTAGE.prn GET #20, UNIT, TNCUTA ' INPUT NO-CUT AGE CLOSE #20 STANDAGE(0) = (TNCUTA.A1 - 10) STANDAGE(1) = TNCUTA.A1 STANDAGE(2) = TNCUTA.A2 STANDAGE(3) = TNCUTA.A3 STANDAGE(4) = TNCUTA.A4 STANDAGE(5) = TNCUTA.A5 STANDAGE(6) = TNCUTA.A6 STANDAGE(7) = TNCUTA.A7 STANDAGE(8) = TNCUTA.A8 STANDAGE(9) = TNCUTA.A9 STANDAGE(10) = TNCUTA.A10 OPEN DATA37 FOR RANDOM AS #37 ' OPEN REVENUE.prn GET #37, UNIT, TREVNU ' INPUT REVENUE CLOSE #37 REVNU = TREVNU.REV OPEN DATA38 FOR RANDOM AS #38 ' OPEN HAULCOST.prn GET #38, UNIT, THCST ' INPUT HAUL COST CLOSE #38 HCOST = THCST.C IF SPP = 1 THEN ' IF MEADOW, BYPASS IF UNIT = UCOUNT THEN GOTO AMELIA GOTO BUCKINGHAM END IF FOR U = 11 TO 19 STANDAGE(U) = STANDAGE(U - 1) + (10 * (U - 10)) NEXT U FOR A = 1 TO 10 IF STANDAGE(A) > 300 THEN STANDAGE(A) = 300 NEXT A IF BS > 0 THEN IF STANDAGE(LCPERIOD) < 50 OR STANDAGE(LCPERIOD) > 150 THEN IF UNIT = UCOUNT THEN GOTO AMELIA ELSE GOTO BUCKINGHAM END IF END IF REM TO THIS POINT, WE HAVE CULLED OUT THE MEADOWS REM AND STANDS NOT MEETING AGE REQUIREMENTS DURING LCPERIOD IF SLOPE < 36 THEN ' GROUND-BASED SYSTEMS IF SPP = 2 THEN XX = 5 ' SPP = 2, SYS = 5-8 IF SPP = 3 AND STANDAGE(LCPERIOD) < 101 AND RIPAR = 0 THEN XX = 5 IF SPP = 3 AND STANDAGE(LCPERIOD) > 100 AND RIPAR = 0 THEN XX = 1 IF SPP = 3 AND RIPAR = 1 THEN XX = 5 IF SPP = 4 THEN XX = 5 ' ETC. IF SPP = 5 THEN XX = 5 IF SPP = 6 THEN XX = 5 ELSE ' SKYLINE, ETC., SYSTEMS IF SPP = 2 THEN XX = 7 ' SPP = 2, SYS = 7-8 IF SPP = 3 AND STANDAGE(LCPERIOD) < 101 AND RIPAR = 0 THEN XX = 7 IF SPP = 3 AND STANDAGE(LCPERIOD) > 100 AND RIPAR = 0 THEN XX = 3 IF SPP = 3 AND RIPAR = 1 THEN XX = 7 IF SPP = 4 THEN XX = 7 ' ETC. IF SPP = 5 THEN XX = 7 IF SPP = 6 THEN XX = 7 END IF FOR P = 1 TO 3 ' FOR EACH SILVICULTURAL SYSTEM FOR W = 1 TO 19 C(W) = 0 ' SET ALL HARVEST CHOICES TO 0 VOL(W) = 0 ' SET ALL VOLUMES CUT TO 0 LEFT(W) = 0 ' SET ALL VOLUMES LEFT TO 0 NEXT W QSPOT = 0 ' SET THE MARKER FOR N = 0 TO 8 ' SETTING ALL COSTS TO NEGATIVE PMCOST(N) = -99999999999# ' FOR EACH SYSTEM 0-8 NEXT N IF SPP = 3 AND P = 3 THEN ' FOR LODGEPOLE PINE, P = 3 ONLY OPEN DATA71 FOR RANDOM AS #71 GET #71, UNIT, TBADU CLOSE #71 IF TBADU.U = 1 THEN GOTO MAPLE1 ' NO PATH FOR CANDIDATE, ' TO HELICOPTER IF XX = 1 THEN ' GROUND-BASED, CC FIRST X = 1 C(LCPERIOD) = 1 VOL(LCPERIOD) = VOLUME(LCPERIOD) ' TOTAL VOLUME FROM NOCUTCOL.prn C(LCPERIOD + 5) = 5 VOL(LCPERIOD + 5) = MBFVOL(5, 3) * AREA * PERCENTCUT(XX) C(LCPERIOD + 7) = 1 VOL(LCPERIOD + 7) = (MBFVOL(5, 3) * .67 * RATE(5, 3) * RATE(6, 3)) * AREA STANDAGE(LCPERIOD + 1) = 10 FOR O = 2 TO 7 STANDAGE(LCPERIOD + O) = STANDAGE(LCPERIOD + (O - 1)) + 10 NEXT O STANDAGE(LCPERIOD + 8) = 10 STANDAGE(LCPERIOD + 9) = 20 QSPOT = 1 GOTO SPRINGFIELD QSPOT1: ELSEIF XX = 3 THEN ' SKYLINE, CC FIRST X = 3 C(LCPERIOD) = 3 VOL(LCPERIOD) = VOLUME(LCPERIOD) C(LCPERIOD + 5) = 7 VOL(LCPERIOD + 5) = MBFVOL(5, 3) * AREA * PERCENTCUT(XX) C(LCPERIOD + 7) = 3 VOL(LCPERIOD + 7) = (MBFVOL(5, 3) * .67 * RATE(5, 3) * RATE(6, 3)) * AREA STANDAGE(LCPERIOD + 1) = 10 FOR O = 2 TO 7 STANDAGE(LCPERIOD + O) = STANDAGE(LCPERIOD + (O - 1)) + 10 NEXT O STANDAGE(LCPERIOD + 8) = 10 STANDAGE(LCPERIOD + 9) = 20 QSPOT = 2 GOTO SPRINGFIELD QSPOT2: ELSEIF XX = 5 THEN ' GROUND-BASED, THIN FIRST X = 5 C(LCPERIOD) = 5 VOL(LCPERIOD) = VOLUME(LCPERIOD) * PERCENTCUT(XX) C(LCPERIOD + 2) = 1 VOL(LCPERIOD + 2) = (VOLUME(LCPERIOD) * .67 * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), 3) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), 3)) C(LCPERIOD + 7) = 5 VOL(LCPERIOD + 7) = MBFVOL(5, 3) * AREA * PERCENTCUT(XX) C(LCPERIOD + 9) = 1 VOL(LCPERIOD + 9) = (MBFVOL(5, 3) * .67 * RATE(5, 3) * RATE(6, 3)) * AREA STANDAGE(LCPERIOD + 3) = 10 FOR O = 4 TO 9 STANDAGE(LCPERIOD + O) = STANDAGE(LCPERIOD + (O - 1)) + 10 NEXT O QSPOT = 3 GOTO SPRINGFIELD QSPOT3: ELSEIF XX = 7 THEN ' SKYLINE, THIN FIRST X = 7 C(LCPERIOD) = 7 VOL(LCPERIOD) = VOLUME(LCPERIOD) * PERCENTCUT(XX) C(LCPERIOD + 2) = 3 VOL(LCPERIOD + 2) = (VOLUME(LCPERIOD) * .67 * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), 3) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), 3)) C(LCPERIOD + 7) = 7 VOL(LCPERIOD + 7) = MBFVOL(5, 3) * AREA * PERCENTCUT(XX) C(LCPERIOD + 9) = 3 VOL(LCPERIOD + 9) = (MBFVOL(5, 3) * .67 * RATE(5, 3) * RATE(6, 3)) * AREA STANDAGE(LCPERIOD + 3) = 10 FOR O = 4 TO 9 STANDAGE(LCPERIOD + O) = STANDAGE(LCPERIOD + (O - 1)) + 10 NEXT O QSPOT = 4 GOTO SPRINGFIELD QSPOT4: END IF MAPLE1: IF XX = 1 OR XX = 3 THEN ' HELICOPTER, CC FIRST X = 4 C(LCPERIOD) = 4 VOL(LCPERIOD) = VOLUME(LCPERIOD) C(LCPERIOD + 5) = 8 VOL(LCPERIOD + 5) = MBFVOL(5, 3) * AREA * .33 C(LCPERIOD + 7) = 4 VOL(LCPERIOD + 7) = (MBFVOL(5, 3) * .67 * RATE(6, 3) * RATE(7, 3)) * AREA STANDAGE(LCPERIOD + 1) = 10 FOR O = 2 TO 7 STANDAGE(LCPERIOD + O) = STANDAGE(LCPERIOD + (O - 1)) + 10 NEXT O STANDAGE(LCPERIOD + 8) = 10 STANDAGE(LCPERIOD + 9) = 20 QSPOT = 5 GOTO SPRINGFIELD QSPOT5: ELSEIF XX = 5 OR XX = 7 THEN ' HELICOPTER, THIN FIRST X = 8 C(LCPERIOD) = 8 VOL(LCPERIOD) = VOLUME(LCPERIOD) * PERCENTCUT(XX) C(LCPERIOD + 2) = 4 VOL(LCPERIOD + 2) = (VOLUME(LCPERIOD) * .67 * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), 3) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), 3)) C(LCPERIOD + 7) = 8 VOL(LCPERIOD + 7) = MBFVOL(5, 3) * AREA * PERCENTCUT(XX) C(LCPERIOD + 9) = 4 VOL(LCPERIOD + 9) = (MBFVOL(5, 3) * .67 * RATE(5, 3) * RATE(6, 3)) * AREA STANDAGE(LCPERIOD + 3) = 10 FOR O = 4 TO 9 STANDAGE(LCPERIOD + O) = STANDAGE(LCPERIOD + (O - 1)) + 10 NEXT O QSPOT = 6 GOTO SPRINGFIELD QSPOT6: END IF ELSEIF P = 1 THEN ' 30 -YEAR RETURN INTERVAL OPEN DATA71 FOR RANDOM AS #71 GET #71, UNIT, TBADU CLOSE #71 IF TBADU.U = 1 THEN GOTO MAPLE2 ' NO PATH FOR CANDIDATE, ' TO HELICOPTER IF XX = 5 THEN ' GROUND-BASED X = 5 C(LCPERIOD) = 5 VOL(LCPERIOD) = VOLUME(LCPERIOD) * PERCENTCUT(XX) LEFT(LCPERIOD) = VOLUME(LCPERIOD) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 3) = 5 VOL(LCPERIOD + 3) = (LEFT(LCPERIOD) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP)) * PERCENTCUT(XX) LEFT(LCPERIOD + 3) = (LEFT(LCPERIOD) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP)) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 6) = 5 VOL(LCPERIOD + 6) = (LEFT(LCPERIOD + 3) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 4), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 5), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 6), SPP)) * PERCENTCUT(XX) LEFT(LCPERIOD + 6) = (LEFT(LCPERIOD + 3) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 4), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 5), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 6), SPP)) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 9) = 5 VOL(LCPERIOD + 9) = (LEFT(LCPERIOD + 6) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 7), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 8), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 9), SPP)) * PERCENTCUT(XX) QSPOT = 7 GOTO SPRINGFIELD QSPOT7: ELSEIF XX = 7 THEN ' SKYLINE X = 7 C(LCPERIOD) = 7 VOL(LCPERIOD) = VOLUME(LCPERIOD) * PERCENTCUT(XX) LEFT(LCPERIOD) = VOLUME(LCPERIOD) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 3) = 7 VOL(LCPERIOD + 3) = (LEFT(LCPERIOD) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP)) * PERCENTCUT(XX) LEFT(LCPERIOD + 3) = (LEFT(LCPERIOD) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP)) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 6) = 7 VOL(LCPERIOD + 6) = (LEFT(LCPERIOD + 3) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 4), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 5), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 6), SPP)) * PERCENTCUT(XX) LEFT(LCPERIOD + 6) = (LEFT(LCPERIOD + 3) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 4), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 5), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 6), SPP)) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 9) = 7 VOL(LCPERIOD + 9) = (LEFT(LCPERIOD + 6) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 7), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 8), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 9), SPP)) * PERCENTCUT(XX) QSPOT = 8 GOTO SPRINGFIELD QSPOT8: END IF MAPLE2: IF XX = 5 OR XX = 7 THEN ' HELICOPTER X = 8 C(LCPERIOD) = 8 VOL(LCPERIOD) = VOLUME(LCPERIOD) * PERCENTCUT(XX) LEFT(LCPERIOD) = VOLUME(LCPERIOD) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 3) = 8 VOL(LCPERIOD + 3) = (LEFT(LCPERIOD) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP)) * PERCENTCUT(XX) LEFT(LCPERIOD + 3) = (LEFT(LCPERIOD) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP)) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 6) = 8 VOL(LCPERIOD + 6) = (LEFT(LCPERIOD + 3) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 4), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 5), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 6), SPP)) * PERCENTCUT(XX) LEFT(LCPERIOD + 6) = (LEFT(LCPERIOD + 3) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 4), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 5), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 6), SPP)) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 9) = 8 VOL(LCPERIOD + 9) = (LEFT(LCPERIOD + 6) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 7), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 8), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 9), SPP)) * PERCENTCUT(XX) QSPOT = 9 GOTO SPRINGFIELD QSPOT9: END IF ELSEIF P = 2 THEN ' 50 -YEAR RETURN INTERVAL OPEN DATA71 FOR RANDOM AS #71 GET #71, UNIT, TBADU CLOSE #71 IF TBADU.U = 1 THEN GOTO MAPLE3 ' NO PATH FOR CANDIDATE, ' TO HELICOPTER IF XX = 5 THEN ' GROUND-BASED X = 5 C(LCPERIOD) = 5 VOL(LCPERIOD) = VOLUME(LCPERIOD) * PERCENTCUT(XX) LEFT(LCPERIOD) = VOLUME(LCPERIOD) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 5) = 5 VOL(LCPERIOD + 5) = (LEFT(LCPERIOD) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP) * RATE(INT( _ (STANDAGE(LCPERIOD) / 10) + 4), SPP)) * PERCENTCUT(XX) QSPOT = 10 GOTO SPRINGFIELD QSPOT10: ELSEIF XX = 7 THEN ' SKYLINE X = 7 C(LCPERIOD) = 7 VOL(LCPERIOD) = VOLUME(LCPERIOD) * PERCENTCUT(XX) LEFT(LCPERIOD) = VOLUME(LCPERIOD) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 5) = 7 VOL(LCPERIOD + 5) = (LEFT(LCPERIOD) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP) * RATE(INT( _ (STANDAGE(LCPERIOD) / 10) + 4), SPP)) * PERCENTCUT(XX) QSPOT = 11 GOTO SPRINGFIELD QSPOT11: END IF MAPLE3: IF XX = 5 OR XX = 7 THEN ' HELICOPTER X = 8 C(LCPERIOD) = 8 VOL(LCPERIOD) = VOLUME(LCPERIOD) * PERCENTCUT(XX) LEFT(LCPERIOD) = VOLUME(LCPERIOD) * (1 - PERCENTCUT(XX)) C(LCPERIOD + 5) = 8 VOL(LCPERIOD + 5) = (LEFT(LCPERIOD) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 1), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 2), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP) * RATE(INT((STANDAGE(LCPERIOD) / 10) + 3), SPP) * RATE(INT( _ (STANDAGE(LCPERIOD) / 10) + 4), SPP)) * PERCENTCUT(XX) QSPOT = 12 GOTO SPRINGFIELD QSPOT12: END IF END IF IF QSPOT = 0 THEN GOTO TEJAS OPEN DATA45 FOR RANDOM AS #45 ' OPEN INSOL.prn GET #45, UNIT, TINSOL CLOSE #45 IF TINSOL.PER = LCPERIOD AND TINSOL.SILV = P THEN FOR U = 1 TO 8 IF TINSOL.SYS = U THEN PMCOST(U) = -99999999999# NEXT U END IF PRINT #21, UNIT; LCPERIOD; P; -99999999999#; PMCOST(1); PMCOST(2); PMCOST(3); PMCOST(4); PMCOST(5); PMCOST(6); PMCOST(7); PMCOST(8) TEJAS: NEXT P END IF PMCOST(0) = (PV + HCOST - REVNU) OPEN DATA27 FOR RANDOM AS #27 ' CHECK TABU STATE GET #27, UNIT, TTABUU.T CLOSE #27 IF (TTABUU.T > 0 AND (PMCOST(0) - 1) < BESTNPV) THEN GOTO BUCKINGHAM END IF OPEN DATA45 FOR RANDOM AS #45 ' OPEN INSOL.prn GET #45, UNIT, TINSOL CLOSE #45 IF TINSOL.PER = 0 THEN PMCOST(0) = -99999999999# ELSE PRINT #19, UNIT; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0 END IF IF PMCOST(0) > -99999999998# THEN PRINT #21, UNIT; 0; 0; PMCOST(0); -99999999999#; -99999999999#; -99999999999#; -99999999999#; -99999999999#; -99999999999#; -99999999999#; -99999999999# END IF BUCKINGHAM: LOOP AMELIA: CLOSE #1 ' CLOSE UNITS.PRN CLOSE #19 ' CLOSE REGIMES.PRN CLOSE #21 ' CLOSE UNITNPV.PRN GOTO SHELBYVILLE ' EXIT SUBROUTINE REM **************************************************************** REM REM Part 2. Calculating Costs REM REM **************************************************************** SPRINGFIELD: ' CALCULATING COSTS FOR I = LCPERIOD TO 19 ' CUTTING OFF CHOICES AT AGE IF STANDAGE(I) > 150 THEN ' 150 C(I) = 0 VOL(I) = 0 END IF NEXT I PMCOST(X) = 0 FOR I = 1 TO 10 HAULCOST(I) = 0 NEXT I FOR I = LCPERIOD TO 10 ' FOR EACH PERIOD IF C(I) = 0 THEN GOTO BOTTOM ' IF NO HARVEST, NEXT I W = (((C(I) - 1) * UCOUNT) + UNIT) OPEN DATA42 FOR RANDOM AS #42 ' OPEN ENTRY.prn GET #42, W, TENTRY ' INPUT UNIT, SYSTEM, ENTRY NODE ENNODE = TENTRY.E CLOSE #42 W = (((I - 1) * NODES) + ENNODE) OPEN DATA40 FOR RANDOM AS #40 ' OPEN MNTCOST.PRN GET #40, W, TMNTCOST FIXEDC = TMNTCOST.F VARIAC = TMNTCOST.V CLOSE #40 HAULCOST(I) = (FIXEDC + (VARIAC * VOL(I))) / (1.04 ^ ((I - 1) * 10 + 5)) PMCOST(X) = PMCOST(X) + (((STUMPAGE(SPP) - LOGCOST(C(I))) * VOL(I)) / (1.04 ^ ((I - 1) * 10 + 5))) - HAULCOST(I) 'IF UNIT = 108 THEN ' PRINT USING "UNIT #### PERIOD ### SYSTEM ### CUT ####.##"; UNIT; I; X; VOL(I) ' PRINT USING "FIXED #####.## VAR ####.## MCOST #####.##"; FIXEDC; VARIAC; HAULCOST(I) ' CC = INPUT$(1) 'END IF BOTTOM: NEXT I ' MAINTENANCE COST LOOP PMCOST(X) = PV + PMCOST(X) + HCOST - REVNU OPEN DATA27 FOR RANDOM AS #27 ' CHECK TABU STATE GET #27, UNIT, TTABUU.T CLOSE #27 IF TTABUU.T > 0 AND (PMCOST(X) - 1) > BESTNPV THEN PRINT #19, UNIT; P; C(LCPERIOD); C(1); C(2); C(3); C(4); C(5); C(6); C(7); C(8); C(9); C(10) ELSEIF TTABUU.T < 1 THEN ' IF NOT TABU PRINT #19, UNIT; P; C(LCPERIOD); C(1); C(2); C(3); C(4); C(5); C(6); C(7); C(8); C(9); C(10) ELSE PMCOST(X) = -99999999999# ' IF NO ASPIRATION, NO CANDIDATE END IF IF QSPOT = 1 THEN GOTO QSPOT1 ' RE-TRACING MY PATH IF QSPOT = 2 THEN GOTO QSPOT2 ' BACK TO THE CODE ABOVE IF QSPOT = 3 THEN GOTO QSPOT3 ' "SPRINGFIELD" IF QSPOT = 4 THEN GOTO QSPOT4 IF QSPOT = 5 THEN GOTO QSPOT5 IF QSPOT = 6 THEN GOTO QSPOT6 IF QSPOT = 7 THEN GOTO QSPOT7 IF QSPOT = 8 THEN GOTO QSPOT8 IF QSPOT = 9 THEN GOTO QSPOT9 IF QSPOT = 10 THEN GOTO QSPOT10 IF QSPOT = 11 THEN GOTO QSPOT11 IF QSPOT = 12 THEN GOTO QSPOT12 SHELBYVILLE: PRINT " Finished Generating a Neighborhood for Units" REM ************************************************************ REM REM END - DEVELOPING UNIT NEIGHBORHOOD ' VERIFIED 9/10/95 REM ' VERIFIED 10/8/95 REM ************************************************************ END SUB SUB R1R4 (Y(), W(), UCOUNT, NODES, LINKS) ' Y() = SHORT LIST FOR ROADS (ACCOUNT(50,3)) ' W() = SEDIMENT(10), UCOUNT = UNITS, NODES = ROADS REM ****************************************************************** REM REM R1/R4 Sediment Model REM DECEMBER 10, 1995 REM REM PETE BETTINGER REM REM This model separates erosional and delivery processes and REM considers them individually for each land unit. This model can REM estimate sediment yield differences among land units and can be REM used to estimate sediment yield from alternative management REM strategies. REM REM USDA Forest Service. 1981. Guide for predicting sediment yields REM from forested watersheds. USDA Forest Service, Northern Region, REM Missoula, MT, and Intermountain Region, Ogden, UT, Soil and Water REM Management. 48 p. REM REM => Sediment will be expressed as total sediment delivered to a REM stream REM => Standard units are (tons/sq.mi./year) REM => Sediment in the stream is expressed as total sediment (bedload REM + suspended REM REM Four major parts to the program: REM 1. Natural sediment yield REM 2. Sediment from surface erosion (ADDED TRAFFIC SEDIMENT CODE REM NOT IN RIR4 - PART 2aa) REM 3. Sediment from mass erosion (NOT A MAJOR PROBLEM) REM 4. Routing of sediment to critical reach REM REM ****************************************************************** REM COMMENTS: REM 1. Need rock type and road standard for each road segment REM 2. Need ground slope and harvest system for each land unit REM REM 3. REMEMBER TO RANDOMIZE TIMER REM REM ****************************************************************** COLOR 2, 0 PRINT PRINT "R1R4 STREAM SEDIMENT MODEL" COLOR 7, 0 DIM TENTRY AS TENTRYNODE DIM TSED AS TSEDIMENT DIM TLINK AS TLINKS DIM TCUT AS TCUTVOL DIM THARV AS THARVESTC DIM TTABUR AS TTABUROAD DIM DATA1 AS STRING ' USED IN PART 1, DATA FILE NAME DATA1 = "C:\PETE\THESIS\MODULES\UNITS.PRN" DIM DATA2 AS STRING ' USED IN PART 2A, DATA FILE NAME DATA2 = "C:\PETE\THESIS\MODULES\ROADS.PRN" DIM DATA10 AS STRING ' USED IN PART 2B, HARVEST TYPE FILE DATA10 = "C:\PETE\THESIS\MODULES\HARVEST.PRN" DIM DATA13 AS STRING ' USED IN PART 2A, ROAD TYPE FILE DATA13 = "C:\PETE\THESIS\MODULES\ROADTYPE.PRN" DIM DATA16 AS STRING ' USED IN PART 2AA, CUT FILE DATA16 = "C:\PETE\THESIS\MODULES\CUT.PRN" DIM DATA28 AS STRING DATA28 = "C:\PETE\THESIS\MODULES\TABUROAD.PRN" DIM DATA42 AS STRING ' USED IN PART 2AA, ENTRY NODES DATA42 = "C:\PETE\THESIS\MODULES\ENTRYRND.PRN" DIM DATA43 AS STRING ' USED IN PART 2AA, SEDIMENT / ROAD DATA43 = "C:\PETE\THESIS\MODULES\SEDRND.PRN" DIM UNIT AS SINGLE ' USED IN PART 1, INPUT FROM FILE DIM HAZRATE AS SINGLE ' USED IN PART 1, INPUT FROM FILE DIM UNITNATSED AS SINGLE ' CALCULATED IN PART 1 DIM CC AS STRING ' USED EVERYWHERE TO BREAK PROGRAM DIM UNITTONS AS SINGLE ' USED IN PART 1, UNIT TONS (NATURAL SED.) DIM TOTALAREA AS SINGLE ' USED IN PART 1 TO SUM UP THE AREA OF TOTALAREA = 0 ' THE PLANNING AREA DIM TOTALTONS AS SINGLE ' USED IN PART 1 TO SUM UP NATURAL SED. TOTALTONS = 0 ' FROM EACH UNIT DIM GEF(8) AS SINGLE ' USED IN PART 2, GEOLOGIC EROSION FACTORS GEF(1) = 1 ' FROM P. 13, R1/R4 GUIDELINES GEF(2) = .42 GEF(3) = .35 GEF(4) = .39 GEF(5) = .75 GEF(6) = .52 GEF(7) = .66 GEF(8) = 1.05 DIM RDWIDTH AS SINGLE ' USED IN PART 2A, AVERAGE ROAD WIDTH DIM ROADSED(3, 3) AS SINGLE ' USED IN PART 2A, SEDIMENT RATE FOR ROADS DIM FROMNODE AS SINGLE ' USED IN PART 2A, FROM NODE DIM TONODE AS SINGLE ' USED IN PART 2A, TO NODE DIM D1 AS SINGLE ' USED IN PART 2A, ROAD LENGTH DIM STD(10) AS SINGLE ' USED IN PART 2A, ROAD STANDARD DIM LENGTH AS SINGLE ' USED IN PART 2A, ROAD LENGTH DIM GEFACTOR AS SINGLE ' USED IN PART 2A, GEOLOGIC EROSION FACTOR DIM RDAREA AS SINGLE ' USED IN PART 2A, ROAD AREA FOR EACH ROAD DIM TOTRDAREA(10) AS SINGLE ' USED IN PART 2A, SUMMATION OF ROAD AREAS DIM RDSED AS SINGLE ' USED IN PART 2A, ROAD SEDIMENT DIM RDSED1 AS SINGLE ' USED IN PART 2A, ROAD SEDIMENT, YEAR 1 DIM RDSED2 AS SINGLE ' USED IN PART 2A, ROAD SEDIMENT, YEAR 2 DIM RDSED3 AS SINGLE ' USED IN PART 2A, ROAD SEDIMENT, YEAR 3 DIM RDSED4 AS SINGLE ' USED IN PART 2A, ROAD SEDIMENT, YEAR 4 DIM RDSED5 AS SINGLE ' USED IN PART 2A, ROAD SEDIMENT, YEAR 5 DIM FRND2 AS SINGLE ' USED IN PART 2A, FROM NODE FROM ROADTYPE.PRN DIM TOND2 AS SINGLE ' USED IN PART 2A, TO NODE FROM ROADTYPE.PRN DIM RDTYPE AS SINGLE ' USED IN PART 2A, ROAD TYPE BEGINNING OF DECADE DIM RDTYPE1 AS SINGLE ' USED IN PART 2A, ROAD TYPE END OF DECADE DIM TOTRDSED AS SINGLE ' USED IN PART 2A, TOTAL ROAD SEDIMENT, DECADE DIM PERIODSED(10) AS SINGLE ' USED IN PART 2A, SEDIMENT FOR EACH PERIOD DIM AVGRDSED AS SINGLE ' USED IN PART 2A, AVERAGE ROAD SED/PERIOD DIM SUMRDSED(10) AS SINGLE ' USED IN PART 2A, SUM OF ROAD SED FOR ALL RDS DIM ACCOUNT(100, 3) AS SINGLE ' USED IN PART 2A, TRACKING ROADS WITH HI SED DIM CTIREDUCTION AS SINGLE ' USED IN PART 2A, CTI REDUCTION IN SEDIMENT CTIREDUCTION = 1 ' NO REDUCTION IN SEDIMENT BY ROAD ITSELF DIM VITREDUCTION AS SINGLE ' USED IN PART 2AA, VTI REDUCTION IN SEDIMENT VTIREDUCTION = .6 ' 60% REDUCTION IN SEDIMENT FROM TRAFFIC DIM TRAFFICSED(10) AS SINGLE ' USED IN PART 2AA, SEDIMENT FROM TRAFFIC DIM SEDFACT AS SINGLE ' USED IN PART 2AA, TRAFFIC FACTOR TONS/MBF/MI DIM CUT(10) AS SINGLE ' USED IN PART 2AA, HARVEST VOLUME SEDFACT = .0000064 ' SEE 10/8/95 NOTES (TONS/MBF-FT/YR) DIM FOIEON(6) AS SINGLE ' USED IN PART 2B, FACTOR OF INCREASED EROSION FOIEON(1) = 2.5 ' OVER NATURAL FOIEON(2) = 1.792 FOIEON(3) = 1.616 FOIEON(4) = 1.396 FOIEON(5) = 1.176 FOIEON(6) = 1.088 DIM SYS(10) AS SINGLE ' USED IN PART 2B, LOGGING SYSTEM DIM SLOPE AS SINGLE ' USED IN PART 2B, GROUND SLOPE DIM LOGSYS(8) AS SINGLE ' USED IN PART 2B, HARVEST TYPE / LOGGING SYS. LOGSYS(1) = 1 ' CLEARCUT / TRACTOR LOGSYS(2) = 1.6129 ' CLEARCUT / CABLE LOGSYS(3) = 3.0303 ' CLEARCUT / SKYLINE LOGSYS(4) = 5.2632 ' CLEARCUT / AERIAL LOGSYS(5) = 1.4085 ' PARTIAL CUT / TRACTOR LOGSYS(6) = 2.3256 ' PARTIAL CUT / CABLE LOGSYS(7) = 3.4483 ' PARTIAL CUT / SKYLINE LOGSYS(8) = 7.1429 ' PARTIAL CUT / AERIAL DIM Y1 AS SINGLE ' USED IN PART 2B, TEMPORARY VARIABLE DIM Y2 AS SINGLE ' USED IN PART 2B, TEMPORARY VARIABLE DIM LUSF AS SINGLE ' USED IN PART 2B, LAND UNIT SLOPE FACTOR DIM AVGUNITSED(10) AS SINGLE ' USED IN PART 2B, AVERAGE (100yr) UNIT SEDIMENT DIM TOTUNITSED AS SINGLE ' USED IN PART 2B, TOTAL UNIT SEDIMENT DIM SUMUNITSED(10) AS SINGLE ' USED IN PART 2B, HARVEST SEDIMENT PER PERIOD DIM HCHOICE(10) AS SINGLE ' USED IN PART 2B, HARVEST CHOICES DIM WA AS SINGLE ' USED IN PART 2C, WATER AVAILABILITY DIM TEM AS SINGLE ' USED IN PART 2C, TEXTURE OF ERODED MATERIAL DIM GC AS SINGLE ' USED IN PART 2C, GROUND COVER DIM SS AS SINGLE ' USED IN PART 2C, SLOPE SHAPE DIM SG AS SINGLE ' USED IN PART 2C, SLOPE GRADIENT DIM DD AS SINGLE ' USED IN PART 2C, DELIVERY DISTANCE DIM SR AS SINGLE ' USED IN PART 2C, SURFACE ROUGHNESS DIM SSF AS SINGLE ' USED IN PART 2C, SITE-SPECIFIC FACTOR DIM STIFF AS SINGLE ' USED IN PART 2C, STIFF POLYGON DIM IV23 AS SINGLE ' USED IN PART 2C, ADJUSTMENT FACTOR FOR STIFF DIM ROEHL AS SINGLE ' USED IN PART 4, ROEHL'S COEFFICIENT DIM WATERSHED AS SINGLE ' USED IN PART 4, WATERSHED SIZE, SQ.MI. DIM WSED AS SINGLE ' USED IN PART 4, WEIGHTED SEDIMENT FOR UNITS DIM ADJUNITSED(10) AS SINGLE ' USED IN PART 4, ADJUSTMENT TO UNIT SEDIMENT DIM SEDIMENT(10) AS SINGLE ' USED IN PART 4, SEDIMENT FOR PERIOD J DIM SPP AS SINGLE ' NOT USED IN R1R4 - SPECIES DIM BA AS SINGLE ' NOT USED IN R1R4 - BASAL AREA PER ACRE DIM AGE AS SINGLE ' NOT USED IN R1R4 - STAND AGE DIM VOLUME AS SINGLE ' NOT USED IN R1R4 - STAND VOLUME PER ACRE REM ******* STIFF VARIABLES ************ WA = .05 ' WATER AVAILABILITY - CHANGED LATER TEM = 50 ' TEM - CHANGED LATER - USING AVERAGE K FACTOR GC = 17 ' GROUND COVER - CHANGED LATER SS = 1 ' SLOPE SHAPE - CONSERVATIVE DD = 100 ' DELIVERY DISTANCE - CHANGED LATER - USING DISTANCE TO STREAM SR = 1 ' SURFACE ROUGHNESS - CONSERVATIVE SG = 50 ' SLOPE GRADIENT - CHANGED LATER - USING SLOPE % SSF = 0 ' SITE-SPECIFIC FACTOR - NONE REM ********************************************* REM Part 1. Natural Sediment Yield REM ********************************************* REM REM Natural range for interior West = 10-100 tons/sq.mi./yr (normal is REM 25 tons/sq.mi./yr) REM REM Need input file with unit, area, erosion hazard rating REM PRINT " Part 1. Natural Sediment Yield" OPEN DATA1 FOR INPUT AS #1 DO WHILE NOT EOF(1) ' FOR ALL UNITS, CALCULATE NATURAL SED. INPUT #1, UNIT, AREA, HAZRATE, SYS, GEFACTOR, SLOPE, SPP, BA, AGE, VOLUME, DISTSTR, RIPAR, AVGK UNITNATSED = 10 ^ (1.014855 ^ (HAZRATE - 10)) * AREA TOTALAREA = TOTALAREA + AREA TOTALTONS = TOTALTONS + UNITNATSED ' VERIFIED 7/1/95 LOOP CLOSE #1 AVGNATSED = TOTALTONS / TOTALAREA PRINT USING " Weighted Average Natural Sediment = ####.# tons/sq.mi./year"; AVGNATSED; REM ***** AVGNATSED IS AVERAGE NATURAL SEDIMENT YIELD - TONS/SQMI/YR **** REM ***** this is a weighted average for the watershed REM ********************************************* REM Part 2. Sediment from Surface Erosion REM ********************************************* REM REM This Part is divided into three sections: a) Management effects: roads REM b) Management effects: logging, and c) Slope delivery REM PRINT " Part 2. Sediment from Surface Erosion" REM REM ********************************************* REM Part 2a. Management Effects: Roads REM ********************************************* REM REM Mitigation measures are assumed to be applied prior to the first REM year a road is built REM ROADSED(0, 1) = 250 ' SEDIMENT RATE, YEAR 1, OBLITERATED ROAD ROADSED(0, 2) = 250 ' SEDIMENT RATE, YEAR 2, OBLITERATED ROAD ROADSED(0, 3) = 250 ' SEDIMENT RATE, YEAR 3, OBLITERATED ROAD ROADSED(1, 1) = 3750 ' SEDIMENT RATE, YEAR 1, SURFACED ROAD ROADSED(1, 2) = 3750 ' SEDIMENT RATE, YEAR 2, SURFACED ROAD ROADSED(1, 3) = 3750 ' SEDIMENT RATE, YEAR 3, SURFACED ROAD ROADSED(2, 1) = 67500 ' SEDIMENT RATE, YEAR 1, STANDARD ROAD ROADSED(2, 2) = 18000 ' SEDIMENT RATE, YEAR 2, STANDARD ROAD ROADSED(2, 3) = 5000 ' SEDIMENT RATE, YEAR 3, STANDARD ROAD ROADSED(3, 1) = 5000 ' SEDIMENT RATE, YEAR 1, CTI ROADSED(3, 2) = 5000 ' SEDIMENT RATE, YEAR 2, CTI ROADSED(3, 3) = 5000 ' SEDIMENT RATE, YEAR 3, CTI PRINT " Part 2a. Management Effects: Roads" FOR M = 1 TO 10 SUMRDSED(M) = 0 NEXT M OPEN DATA2 FOR INPUT AS #2 FOR I = 1 TO LINKS ' FOR ALL ROADS, CALCULATE SEDIMENT SSF = 0 INPUT #2, FROMNODE, TONODE, STD, LENGTH, GEFACTOR, DISTSTR, INWS, AVGK, RDSLOPE OPEN DATA28 FOR RANDOM AS #28 ' OPEN TABUROAD.PRN GET #28, I, TTABUR CLOSE #28 TESST = TTABUR.T OPEN DATA13 FOR RANDOM AS #13 GET #13, I, TLINK CLOSE #13 STD(0) = STD STD(1) = TLINK.S1 STD(2) = TLINK.S2 STD(3) = TLINK.S3 STD(4) = TLINK.S4 STD(5) = TLINK.S5 STD(6) = TLINK.S6 STD(7) = TLINK.S7 STD(8) = TLINK.S8 STD(9) = TLINK.S9 STD(10) = TLINK.S10 IF INWS = 0 THEN GOTO PAWS ' IF NOT IN WATERSHED, THEN NEXT ROAD WA = .067 ' SAME WA AS FOR CLEARCUTTING GC = 0 ' 0% GROUND COVER DD = DISTSTR SG = RDSLOPE TEM = AVGK IF SSF = 0 THEN SSF = (((WA * 1000) + SG) / 2) END IF REM *** CALCULATION OF THE STIFF POLYGON AND ITS ADJUSTMENT (IV23) ***** IF (WA * 2000) > SSF THEN PBASE = 197.9899 * WA HT = 197.9899 * (SSF / 2000) A1 = (PBASE * HT * .5) ELSE PBASE = (.14 * SSF) HT = (.14 * (WA * 1000)) A1 = (PBASE * HT * .5) END IF IF (WA * 1000) > TEM THEN PBASE = 197.9899 * WA HT = 197.9899 * (TEM / 2000) B1 = (PBASE * HT * .5) ELSE PBASE = (.14 * TEM) HT = (.14 * (WA * 1000)) B1 = (PBASE * HT * .5) END IF GC1 = 19.79899 - (1 / (.040509287# + 1.42771083# * (1 / (GC + .01)) ^ 1.110833)) IF GC1 < 0 THEN GC2 = 0 ELSE GC2 = GC1 END IF IF ((.14 * TEM) / 14) < (GC2 / 19.79899) THEN PBASE = GC2 HT = (((.14 * TEM) / 14) / 2) * 19.79899 A2 = (PBASE * HT * .5) ELSE PBASE = (.14 * TEM) HT = ((GC2 / 19.79899) * 100) * .14 A2 = (PBASE * HT * .5) END IF IF ((14 - (SS * 3.5)) / 14) < (GC2 / 19.79899) THEN PBASE = GC2 HT = (((14 - (SS * 3.5)) / 14) / 2) * 19.79899 B2 = (PBASE * HT * .5) ELSE PBASE = (14 - (SS * 3.5)) HT = (GC2 / 19.79899) * 14 B2 = (PBASE * HT * .5) END IF IF ((14 - (SS * 3.5)) / 14) < ((19.79899 - (LOG(DD + 1) * .43429448190325#) * 4.94975) / 19.79899) THEN PBASE = (19.79899 - (LOG(DD + 1) * .42439448190325#) * 4.94975) HT = (((14 - (SS * 3.5)) / 14) / 2) * 19.79899 A3 = (PBASE * HT * .5) ELSE PBASE = (14 - (SS * 3.5)) HT = (((19.79899 - (LOG(DD + 1) * .43429448190325#) * 4.94975) / 19.79899) * 14) A3 = (PBASE * HT * .5) END IF IF ((14 - (SR * 3.5)) / 14) < ((19.79899 - (LOG(DD + 1) * .43429448190325#) * 4.94975) / 19.79899) THEN PBASE = (19.79899 - (LOG(DD + 1) * .43429448190325#) * 4.94975) HT = (((14 - (SR * 3.5)) / 14) / 2) * 19.79899 B3 = (PBASE * HT * .5) ELSE PBASE = (14 - (SR * 3.5)) HT = (((19.79899 - (LOG(DD + 1) * .43429448190325#) * 4.94975) / 19.79899) * 14) B3 = (PBASE * HT * .5) END IF IF ((14 - (SR * 3.5)) / 14) < ((.1979899# * SG) / 19.79899) THEN PBASE = (.1979899# * SG) HT = ((((14 - (SR * 3.5)) / 14) / 2) * 19.79899) A4 = (PBASE * HT * .5) ELSE PBASE = (14 - (SR * 3.5)) HT = (((.1979899# * SG) / 19.79899) * 14) A4 = (PBASE * HT * .5) END IF IF SG > (SSF / 2) THEN PBASE = (.1979899# * SG) HT = (.1979899# * (.5 * SSF)) B4 = (.5 * PBASE * HT) ELSE PBASE = (.14 * SSF) HT = (.14 * SG) B4 = (.5 * PBASE * HT) END IF STIFF = (((A1 + B1 + A2 + B2 + A3 + B3 + A4 + B4) / 784) * 100) IV23 = (.0661546948# - .0119380071# * STIFF + .0006192633# * STIFF ^ 2 - .000004135# * STIFF ^ 3) IF STIFF < 11 THEN IV23 = 0 IF STIFF > 89 THEN IV23 = 1 FOR J = 1 TO 10 ' FOR EACH DECADE TOTRDSED = 0 ' INITIAL TOTAL SEDIMENT THIS DECADE IF STD(J - 1) = 0 THEN RDWIDTH1 = 19.35 ' OBLIT. RD WIDTH IF STD(J - 1) = 1 THEN RDWIDTH1 = 52.67 ' PAVED RD WIDTH IF STD(J - 1) = 2 THEN RDWIDTH1 = 19.35 ' ROCK RD WIDTH IF STD(J - 1) = 3 THEN RDWIDTH1 = 19.35 ' CTI ROAD STRETCH IF STD(J) = 0 THEN RDWIDTH2 = 19.35 ' OBLIT. RD WIDTH IF STD(J) = 1 THEN RDWIDTH2 = 52.67 ' PAVED RD WIDTH IF STD(J) = 2 THEN RDWIDTH2 = 19.35 ' ROCK RD WIDTH IF STD(J) = 3 THEN RDWIDTH2 = 19.35 ' CTI ROAD STRETCH RDAREA1 = ((LENGTH * RDWIDTH1) / 43560) / 640 ' ROAD AREA, SQ.MI. RDAREA2 = ((LENGTH * RDWIDTH2) / 43560) / 640 ' ROAD AREA, SQ.MI. TOTRDAREA(J) = TOTRDAREA(J) + ((RDAREA1 + RDAREA2) / 2) IF STD(J - 1) = 3 THEN RDSED = RDAREA1 * ROADSED(STD(J - 1), 3) * CTIREDUCTION * GEF(GEFACTOR) ELSE RDSED = RDAREA1 * ROADSED(STD(J - 1), 3) * GEF(GEFACTOR) END IF TOTRDSED = RDSED * 5 ' FIRST 5 YEARS OF THE DECADE IF STD(J - 1) = STD(J) THEN TOTRDSED = TOTRDSED * 2 ' LAST 5 YEARS OF THE DECADE ELSE IF STD(J) = 3 THEN ' IF CTI RDSED1 = RDAREA2 * ROADSED(STD(J), 1) * CTIREDUCTION * GEF(GEFACTOR) RDSED2 = RDAREA2 * ROADSED(STD(J), 2) * CTIREDUCTION * GEF(GEFACTOR) RDSED3 = RDAREA2 * ROADSED(STD(J), 3) * CTIREDUCTION * GEF(GEFACTOR) RDSED4 = RDAREA2 * ROADSED(STD(J), 3) * CTIREDUCTION * GEF(GEFACTOR) RDSED5 = RDAREA2 * ROADSED(STD(J), 3) * CTIREDUCTION * GEF(GEFACTOR) TOTRDSED = TOTRDSED + RDSED1 + RDSED2 + RDSED3 + RDSED4 + RDSED5 ELSE RDSED1 = RDAREA2 * ROADSED(STD(J), 3) * GEF(GEFACTOR) RDSED2 = RDAREA2 * ROADSED(STD(J), 3) * GEF(GEFACTOR) RDSED3 = RDAREA2 * ROADSED(STD(J), 3) * GEF(GEFACTOR) RDSED4 = RDAREA2 * ROADSED(STD(J), 3) * GEF(GEFACTOR) RDSED5 = RDAREA2 * ROADSED(STD(J), 3) * GEF(GEFACTOR) TOTRDSED = TOTRDSED + RDSED1 + RDSED2 + RDSED3 + RDSED4 + RDSED5 END IF END IF TOTIV23 = TOTIV23 + IV23 CNTIV23 = CNTIV23 + 1 PERIODSED(J) = IV23 * (TOTRDSED / 10) ' AVERAGE SEDIMENT PER YEAR IN ' PERIOD J FOR ROAD (I) IF STD(J) = 2 AND TESST = 0 THEN ' STD = ROCK ROAD, NOT TABU CHECK1 = RND CHECK2 = RND IF CHECK1 > CHECK2 THEN FOR N = 1 TO 10 ' FOR 10 SLOTS IN ACCOUNT ARRAY IF (PERIODSED(J) / LENGTH) > ACCOUNT(((J * 10) - (10 - N)), 3) THEN IF N < 9.5 THEN FOR K = (J * 10) TO ((J * 10) - (9 - N)) STEP -1 ACCOUNT(K, 1) = ACCOUNT((K - 1), 1) ' ACCOUNTING PROCEDURE ACCOUNT(K, 2) = ACCOUNT((K - 1), 2) ' SHIFTING VALUES IN ACCOUNT(K, 3) = ACCOUNT((K - 1), 3) ' ACCOUNT ARRAY NEXT K END IF ACCOUNT(((J * 10) - (10 - N)), 1) = FROMNODE ACCOUNT(((J * 10) - (10 - N)), 2) = TONODE ACCOUNT(((J * 10) - (10 - N)), 3) = (PERIODSED(J) / LENGTH) GOTO BREAKOUT END IF NEXT N END IF ' VERIFIED 8/30/95 - RANDOMNESS END IF ' VERIFIED 8/30/95 - ACCOUNT() BREAKOUT: NEXT J ' VERIFIED 7/23/95 - ROAD SED. FOR J = 1 TO 10 ' TOTAL SEDIMENT FOR ALL ROADS SUMRDSED(J) = SUMRDSED(J) + PERIODSED(J) ' ACROSS THE 10 PERIODS NEXT J PAWS: NEXT I CLOSE #2 ' SINGLE PERIOD VERIFIED 7/2/95 FOR M = 1 TO 100 FOR N = 1 TO 3 Y(M, N) = ACCOUNT(M, N) NEXT N ' VERIFIED 8/30/95 NEXT M REM ****** SUMRDSED(J) IS THE SUM OF ROAD SEDIMENT FOR PERIOD J ****** REM ****** this is not a weighted average for the watershed 'FOR K = 1 TO 10 ' PRINT USING " Sediment from Roads, Period ## = ####.## tons/year"; K; SUMRDSED(K) 'NEXT K 'PRINT USING "AVERAGE IV23 FACTOR = #.#####"; (TOTIV23 / CNTIV23) REM ************************************************* REM Part 2aa. Management Effects: Road Traffic REM ************************************************* REM PRINT " Part 2aa. Management Effects: Road Traffic" FOR M = 1 TO 10 TRAFFICSED(M) = 0 NEXT M FOR J = 2 TO UCOUNT ' FOR ALL UNITS OPEN DATA10 FOR RANDOM AS #10 ' OPEN HARVEST.PRN GET #10, J, THARV CLOSE #10 SYS(1) = THARV.C1 SYS(2) = THARV.C2 SYS(3) = THARV.C3 SYS(4) = THARV.C4 SYS(5) = THARV.C5 SYS(6) = THARV.C6 SYS(7) = THARV.C7 SYS(8) = THARV.C8 SYS(9) = THARV.C9 SYS(10) = THARV.C10 OPEN DATA16 FOR RANDOM AS #16 ' OPEN CUT.PRN GET #16, J, TCUT CLOSE #16 CUT(1) = TCUT.C1 CUT(2) = TCUT.C2 CUT(3) = TCUT.C3 CUT(4) = TCUT.C4 CUT(5) = TCUT.C5 CUT(6) = TCUT.C6 CUT(7) = TCUT.C7 CUT(8) = TCUT.C8 CUT(9) = TCUT.C9 CUT(10) = TCUT.C10 FOR I = 1 TO 10 ' FOR EACH PERIOD IF CUT(I) > 0 THEN ' IF A HARVEST OCCURS W = (((SYS(I) - 1) * UCOUNT) + J) OPEN DATA42 FOR RANDOM AS #42 ' OPEN ENTRY.PRN GET #42, W, TENTRY ENNODE = TENTRY.E CLOSE #42 W = (((I - 1) * NODES) + ENNODE) OPEN DATA43 FOR RANDOM AS #43 ' OPEN SEDRND.PRN GET #43, W, TSED SED = TSED.SED CLOSE #43 TRAFFICSED(I) = TRAFFICSED(I) + (SED * CUT(I)) END IF NEXT I NEXT J FOR M = 1 TO 10 ' SINCE TRAFFIC IS ASSUMED TO OCCUR TRAFFICSED(M) = TRAFFICSED(M) / 10 ' IN YEAR 5, I AM REDUCING IT TO A NEXT M ' YEARLY BASIS ' THIS IS NOT ON A /MI.SQ. BASIS REM ********************************************* REM Part 2b. Management Effects: Logging REM ********************************************* REM REM Calculating sediment derived from logging for 6 years (afterwards = 0) REM Assuming logging takes place in year 5 of a decade, and that all 6 REM year's worth of sediment occur in that decade. Thus summing up sediment REM for the entire decade due to logging a unit. REM PRINT " Part 2b. Management Effects: Logging" FOR M = 1 TO 10 SUMUNITSED(M) = 0 NEXT M OPEN DATA1 FOR INPUT AS #1 ' OPEN UNITS.PRN DO WHILE NOT EOF(1) ' FOR ALL UNITS SSF = 0 INPUT #1, UNIT, AREA, HAZRATE, SYS, GEFACTOR, SLOPE, SPP, BA, AGE, VOLUME, DISTSTR, RIPAR, AVGK OPEN DATA10 FOR RANDOM AS #10 ' OPEN HARVEST.PRN GET #10, UNIT, THARV CLOSE #10 HCHOICE(1) = THARV.C1 HCHOICE(2) = THARV.C2 HCHOICE(3) = THARV.C3 HCHOICE(4) = THARV.C4 HCHOICE(5) = THARV.C5 HCHOICE(6) = THARV.C6 HCHOICE(7) = THARV.C7 HCHOICE(8) = THARV.C8 HCHOICE(9) = THARV.C9 HCHOICE(10) = THARV.C10 AVGUNITSED = 0 UNITNATSED = 10 ^ (1.014855 ^ (HAZRATE - 10)) FOR J = 1 TO 10 ' FOR EACH DECADE TOTUNITSED = 0 ' INITIAL LOGGING SEDIMENT IF HCHOICE(J) > 0 THEN ' IF A HARVEST OCCURS IN THIS DECADE J DD = DISTSTR SG = SLOPE TEM = AVGK IF HCHOICE(J) = 1 OR HCHOICE(J) = 2 OR HCHOICE(J) = 5 OR HCHOICE(J) = 6 THEN WA = .067 ELSE WA = .0105 END IF IF HCHOICE(J) = 1 THEN GC = .79 IF HCHOICE(J) = 2 THEN GC = .87 IF HCHOICE(J) = 3 THEN GC = .93 IF HCHOICE(J) = 4 THEN GC = .96 IF HCHOICE(J) = 5 THEN GC = .85 IF HCHOICE(J) = 6 THEN GC = .91 IF HCHOICE(J) = 7 THEN GC = .94 IF HCHOICE(J) = 8 THEN GC = .97 IF SSF = 0 THEN SSF = (((WA * 1000) + SG) / 2) END IF REM *** CALCULATION OF THE STIFF POLYGON AND ITS ADJUSTMENT (IV23) ***** IF (WA * 2000) > SSF THEN PBASE = 197.9899 * WA HT = 197.9899 * (SSF / 2000) A1 = (PBASE * HT * .5) ELSE PBASE = (.14 * SSF) HT = (.14 * (WA * 1000)) A1 = (PBASE * HT * .5) END IF IF (WA * 1000) > TEM THEN PBASE = 197.9899 * WA HT = 197.9899 * (TEM / 2000) B1 = (PBASE * HT * .5) ELSE PBASE = (.14 * TEM) HT = (.14 * (WA * 1000)) B1 = (PBASE * HT * .5) END IF GC1 = 19.79899 - (1 / (.040509287# + 1.42771083# * (1 / (GC + .01)) ^ 1.110833)) IF GC1 < 0 THEN GC2 = 0 ELSE GC2 = GC1 END IF IF ((.14 * TEM) / 14) < (GC2 / 19.79899) THEN PBASE = GC2 HT = (((.14 * TEM) / 14) / 2) * 19.79899 A2 = (PBASE * HT * .5) ELSE PBASE = (.14 * TEM) HT = ((GC2 / 19.79899) * 100) * .14 A2 = (PBASE * HT * .5) END IF IF ((14 - (SS * 3.5)) / 14) < (GC2 / 19.79899) THEN PBASE = GC2 HT = (((14 - (SS * 3.5)) / 14) / 2) * 19.79899 B2 = (PBASE * HT * .5) ELSE PBASE = (14 - (SS * 3.5)) HT = (GC2 / 19.79899) * 14 B2 = (PBASE * HT * .5) END IF IF ((14 - (SS * 3.5)) / 14) < ((19.79899 - (LOG(DD + 1) * .43429448190325#) * 4.94975) / 19.79899) THEN PBASE = (19.79899 - (LOG(DD + 1) * .42439448190325#) * 4.94975) HT = (((14 - (SS * 3.5)) / 14) / 2) * 19.79899 A3 = (PBASE * HT * .5) ELSE PBASE = (14 - (SS * 3.5)) HT = (((19.79899 - (LOG(DD + 1) * .43429448190325#) * 4.94975) / 19.79899) * 14) A3 = (PBASE * HT * .5) END IF IF ((14 - (SR * 3.5)) / 14) < ((19.79899 - (LOG(DD + 1) * .43429448190325#) * 4.94975) / 19.79899) THEN PBASE = (19.79899 - (LOG(DD + 1) * .43429448190325#) * 4.94975) HT = (((14 - (SR * 3.5)) / 14) / 2) * 19.79899 B3 = (PBASE * HT * .5) ELSE PBASE = (14 - (SR * 3.5)) HT = (((19.79899 - (LOG(DD + 1) * .43429448190325#) * 4.94975) / 19.79899) * 14) B3 = (PBASE * HT * .5) END IF IF ((14 - (SR * 3.5)) / 14) < ((.1979899# * SG) / 19.79899) THEN PBASE = (.1979899# * SG) HT = ((((14 - (SR * 3.5)) / 14) / 2) * 19.79899) A4 = (PBASE * HT * .5) ELSE PBASE = (14 - (SR * 3.5)) HT = (((.1979899# * SG) / 19.79899) * 14) A4 = (PBASE * HT * .5) END IF IF SG > (SSF / 2) THEN PBASE = (.1979899# * SG) HT = (.1979899# * (.5 * SSF)) B4 = (.5 * PBASE * HT) ELSE PBASE = (.14 * SSF) HT = (.14 * SG) B4 = (.5 * PBASE * HT) END IF STIFF = (((A1 + B1 + A2 + B2 + A3 + B3 + A4 + B4) / 784) * 100) IV23 = (.0661546948# - .0119380071# * STIFF + .0006192633# * STIFF ^ 2 - .000004135# * STIFF ^ 3) IF STIFF < 11 THEN IV23 = 0 IF STIFF > 89 THEN IV23 = 1 FOR K = 1 TO 6 Y1 = (((FOIEON(K) * (UNITNATSED * 3)) - (UNITNATSED * 3)) / LOGSYS(HCHOICE(J))) * GEF(GEFACTOR) LUSF = (((.43 + .3 * SLOPE + (.043 * SLOPE ^ 2)) * .0374) / 6.613) + .5 Y2 = (Y1 * LUSF) * (AREA / 640) * IV23 TOTUNITSED = TOTUNITSED + Y2 NEXT K END IF AVGUNITSED(J) = TOTUNITSED / 10 ' AVERAGE SEDIMENT / YEAR NEXT J ' FOR UNIT I, DECADE J FOR L = 1 TO 10 ' SUM ACROSS ALL PERIODS SUMUNITSED(L) = SUMUNITSED(L) + AVGUNITSED(L) ' FOR ALL PERIODS NEXT L LOOP ' NEXT UNIT CLOSE #1 ' SINGLE PERIOD VERIFIED 7/2/95 REM ****** SUMUNITSED(J) IS THE SUM OF HARVEST SEDIMENT FOR PERIOD J ****** REM ****** this is not a weighted average for the watershed REM ********************************************* REM Part 2c. Management Effects: Slope delivery REM ********************************************* REM REM Need to deliver downslope to the stream all eroded material from REM Parts 2a and 2b. Check WRENSS, Ch. 4, Surface erosion, p. IV-54 REM to IV-57. This must be developed for each road and land unit. REM REM This procedure is located in the subroutine IV22 REM ' VERIFIED 7/30/95 REM REM ********************************************* REM Part 3. Sediment from Mass Erosion REM ********************************************* REM REM Estimation of mass erosion is the most difficult, least understood, REM and hardest quantify of all parts of this model. If sediment from REM management-induced mass erosion is potentially a significant REM element, it should be estimated and quantified using Ch.5 in WRENSS. REM PRINT " Part 3. Sediment from Mass Erosion - Not a Major Factor" REM REM ********************************************* REM Part 4. Sediment Routing REM ********************************************* REM REM This is a generalized procedure to route sediment to a critical reach. REM Need to add up the sedment derived from Parts 1-3 and mulitply REM Roehl's coefficient by those totals to get total delivered to the REM critical reach. REM PRINT " Part 4. Sediment Routing" PRINT FOR M = 1 TO 10 SEDIMENT(M) = 0 NEXT M WATERSHED = TOTALAREA / 640 ' CALCULATING WATERSHED SIZE (SQ.MI.) ROEHL = WATERSHED ^ (-.18) ' CALCULATING THE SEDIMENT ROUTING COEFF. IF ROEHL > 1 THEN ROEHL = 1 FOR K = 1 TO 10 SUMRDSED(K) = SUMRDSED(K) / WATERSHED ' CONVERTING TO T/SQMI/YR TRAFFICSED(K) = TRAFFICSED(K) / WATERSHED ' CONVERTING TO T/SQMI/YR SUMUNITSED(K) = SUMUNITSED(K) / WATERSHED ' CONVERTING TO T/SQMI/YR ADJUNITSED(K) = (SUMUNITSED(K) * WATERSHED) - (SUMUNITSED(K) * TOTRDAREA(K)) ADJUNITSED(K) = ADJUNITSED(K) / WATERSHED ' CONVERTING TO T/SQMI/YR REM EVERYTHING MUST BE IN TONS/MI^2/YR HERE SEDIMENT(K) = ROEHL * (TRAFFICSED(K) + SUMRDSED(K) + ADJUNITSED(K) + AVGNATSED) 'PRINT USING " Sediment Level, Period ## = ####.## tons/sq.mi./yr"; K; SEDIMENT(K) NEXT K ' VERIFIED 8/5/95 'CC = INPUT$(1) PRINT FOR K = 1 TO 10 PRINT USING " Total ##.## Natural ##.## Road ##.## Traffic ##.## Unit #.####"; SEDIMENT(K); (ROEHL * AVGNATSED); (ROEHL * SUMRDSED(K)); (ROEHL * TRAFFICSED(K)); (ROEHL * ADJUNITSED(K)) NEXT K 'CC = INPUT$(1) FOR I = 1 TO 10 W(I) = SEDIMENT(I) NEXT I REM ************************************************************************ REM REM END - R1R4 SEDIMENT MODEL ' COMPLETED 8/6/95 REM REM ************************************************************************ END SUB SUB RANDOMSTART (UCOUNT, NODES) REM *********************************************************** REM REM RANDOM STARTING POINT ALGORITHM REM DECEMBER 8, 1995 REM PETE BETTINGER REM REM *********************************************************** REM REM This algorithm sets an initial randomly defined solution REM for units to be harvested in period #1. Afterwards the REM main Tabu search will schedule the other period's harvests. REM The first period is set to a goal of 5% of the total acres REM in the watershed. The harvest system selected is the one REM initially defined in UNITS.prn. The main Tabu search REM algorithm can then change the harvest system for each unit. REM REM *********************************************************** COLOR 2, 0 PRINT PRINT "RANDOM STARTING SOLUTION BEING DEFINED" COLOR 7, 0 DIM TENTRY AS TENTRYNODE DIM THARV AS THARVESTC DIM TTABUU AS TTABUUNIT DIM TCUT AS TCUTVOL DIM TINSOL AS TINSOLUTION DIM TMNTCOST AS TMAINTCOST DIM DATA1 AS STRING ' UNITS.prn DATA1 = "C:\PETE\THESIS\MODULES\UNITS.PRN" DIM DATA10 AS STRING ' HARVEST CHOICE FILE DATA10 = "C:\PETE\THESIS\MODULES\HARVEST.PRN" DIM DATA27 AS STRING ' TABU STATE - UNITS FILE DATA27 = "C:\PETE\THESIS\MODULES\TABUUNIT.PRN" DIM DATA40 AS STRING DATA40 = "C:\PETE\THESIS\MODULES\MNTCOST.PRN" DIM DATA42 AS STRING DATA42 = "C:\PETE\THESIS\MODULES\ENTRYRND.PRN" DIM DATA45 AS STRING DATA45 = "C:\PETE\THESIS\MODULES\INSOL.PRN" DIM UNIT AS SINGLE ' UNIT NUMBER DIM AREA AS SINGLE ' UNIT AREA DIM HAZARD AS SINGLE ' EROSION HAZARD RATING DIM SYS AS SINGLE ' LOGGING SYSTEM DIM GEF AS SINGLE ' GEOLOGIC EROSION HAZARD DIM SLOPE AS SINGLE ' GROUND SLOPE PERCENT DIM SPP AS SINGLE ' TREE SPECIES DIM BA AS SINGLE ' BASAL AREA PER ACRE DIM AGE AS SINGLE ' AVERAGE AGE DIM VOLUME AS SINGLE ' MERCH. VOLUME PER ACRE (MBF) DIM TOTAREA AS SINGLE ' TOTAL AREA DIM STOPPOINT AS SINGLE ' STOPPING POINT FOR RANDOM START DIM CC AS STRING ' STOPS CODE DIM THINACRES AS SINGLE ' NUMBER OF THINNING ACRES DIM TARGETSTAND AS SINGLE ' POTENTIAL STAND TO THIN DIM TEMPLIST(1000) AS SINGLE ' TEMPORARY LIST OF UNITS TOTAREA = 0 ' SETTING TOTAL AREA = 0 OPEN DATA1 FOR INPUT AS #1 DO WHILE NOT EOF(1) ' SUMMING AREA AND UNITS INPUT #1, UNIT, AREA, HAZARD, SYS, GEF, SLOPE, SPP, BA, AGE, VOLUME, DISTSTR, RIPAR, AVGK TOTAREA = TOTAREA + AREA LOOP CLOSE #1 ' VERIFIED 9/10/95 STOPPOINT = .05 * TOTAREA ' DEFINING THE STOPPING POINT ' = 5% OF TOTAL AREA FOR I = 1 TO 100 TEMPLIST(I) = 0 NEXT I NUMUNITS = 0 TEMPACRES = 0 DO WHILE TEMPACRES < STOPPOINT ' WHILE ACRES < STOP POINT THEUPPER: TARGETSTAND = INT(RND * (UCOUNT - 2)) + 2 ' RANDOMLY DEFINE A UNIT FOR I = 1 TO 1000 IF I = 1000 THEN PRINT "MAXED OUT ON THE NUMBER OF UNITS IN TEMPLIST()" PRINT " PERHAPS INCREASE THE NUMBER OF POTENTIAL UNITS" PRINT " IN RANDOMSTART" END END IF IF TEMPLIST(I) > 0 THEN ' IF ALREADY SELECTED, GET IF TEMPLIST(I) = TARGETSTAND THEN ' ANOTHER UNIT GOTO THEUPPER END IF END IF IF TEMPLIST(I) = 0 THEN EXIT FOR NEXT I OPEN DATA1 FOR INPUT AS #1 DO WHILE NOT EOF(1) INPUT #1, UNIT, AREA, HAZARD, SYS, GEF, SLOPE, SPP, BA, AGE, VOLUME, DISTSTR, RIPAR, AVGK IF UNIT = TARGETSTAND THEN GOTO BED LOOP BED: CLOSE #1 PRINT USING " GOT UNIT #### SPECIES #"; UNIT; SPP IF SPP = 1 THEN ' IF MEADOW, IGNORE PRINT USING " CAN'T USE UNIT ##### - MEADOW"; UNIT GOTO THEUPPER END IF W = (((SYS - 1) * UCOUNT) + UNIT) OPEN DATA42 FOR RANDOM AS #42 ' FIND ENTRY NODE FOR THE UNIT / GET #42, W, TENTRY ' SYSTEM COMBINATION ENNODE = TENTRY.E CLOSE #42 W = ENNODE OPEN DATA40 FOR RANDOM AS #40 ' OPEN MNTCOST.PRN GET #40, W, TMNTCOST ' FIND MAINT. COSTS FOR ENTRY NODE / VARIAC = TMNTCOST.V ' MILL PATH CLOSE #40 IF VARIAC = 0 THEN ' PATH EXISTS IF VARIAC > 0 PRINT USING " CAN'T USE UNIT ##### - NO PATH"; UNIT GOTO THEUPPER END IF TEMPLIST(I) = TARGETSTAND ' IF NOT ALREADY SELECTED, TEMPAREA = TEMPAREA + AREA ' SUM TEMP ACRES NUMUNITS = NUMUNITS + 1 ' SUM UNITS PRINT USING " STOP POINT ##,###.## ac"; STOPPOINT PRINT USING " AREA SCHEDULED ##,###.## ac, TOTAL NUMBER OF UNITS IS ###"; TEMPAREA; NUMUNITS IF TEMPAREA > STOPPOINT THEN GOTO PROVIDENCE END IF LOOP ' VERIFIED 9/11/95 PROVIDENCE: Q = 0 FOR I = 1 TO 1000 ' DETERMINING THE NUMBER OF UNITS IF TEMPLIST(I) > 0 THEN Q = Q + 1 ' IN TEMPLIST() NEXT I ' VERIFIED 9/11/95 FOR I = 1 TO (Q - 1) ' SORTING TEMPLIST() FOR K = (I + 1) TO Q IF TEMPLIST(I) > TEMPLIST(K) THEN SWAP TEMPLIST(I), TEMPLIST(K) NEXT K NEXT I ' VERIFIED 9/11/95 OPEN DATA1 FOR INPUT AS #1 ' OPEN UNITS.PRN FOR INPUT T = 1 DO WHILE NOT EOF(1) ' FOR ALL UNITS INPUT #1, UNIT, AREA, HAZARD, SYS, GEF, SLOPE, SPP, BA, AGE, VOLUME, DISTSTR, RIPAR, AVGK THARV.SILV = 0 THARV.C1 = 0 THARV.C2 = 0 THARV.C3 = 0 THARV.C4 = 0 THARV.C5 = 0 THARV.C6 = 0 THARV.C7 = 0 THARV.C8 = 0 THARV.C9 = 0 THARV.C10 = 0 TTABUU.T = 0 OPEN DATA45 FOR RANDOM AS #45 ' OPEN INSOL.PRN FOR OUTPUT PUT #45, UNIT, THARV CLOSE #45 IF UNIT = TEMPLIST(T) THEN ' IF IN TEMPLIST() TINSOL.PER = 1 IF SPP = 1 THEN ' IF SPECIES IS MEADOW OPEN DATA10 FOR RANDOM AS #10 ' OPEN HARVEST.PRN FOR OUTPUT PUT #10, UNIT, THARV CLOSE #10 OPEN DATA27 FOR RANDOM AS #27 ' OPEN TABUUNIT.PRN FOR OUTPUT PUT #27, UNIT, TTABUU CLOSE #27 ELSEIF SPP = 3 THEN ' IF LODGEPOLE PINE IF (AGE + 10) > 49 AND (AGE + 10) < 101 AND RIPAR = 0 THEN ' THIN FIRST IF SLOPE < 36 THEN THARV.C1 = 5 THARV.C3 = 1 THARV.C8 = 5 THARV.C10 = 1 TINSOL.SYS = 5 ELSE THARV.C1 = 7 THARV.C3 = 3 THARV.C8 = 7 THARV.C10 = 3 TINSOL.SYS = 7 END IF THARV.SILV = 3 OPEN DATA10 FOR RANDOM AS #10 ' OPEN HARVEST.PRN FOR OUTPUT PUT #10, UNIT, THARV CLOSE #10 TTABUU.T = 125 OPEN DATA27 FOR RANDOM AS #27 PUT #27, UNIT, TTABUU CLOSE #27 TINSOL.SILV = 3 OPEN DATA45 FOR RANDOM AS #45 PUT #45, UNIT, TINSOL CLOSE #45 ELSEIF (AGE + 10) > 100 AND RIPAR = 0 THEN IF SLOPE < 36 THEN ' CLEARCUT FIRST THARV.C1 = 1 THARV.C6 = 5 THARV.C8 = 1 TINSOL.SYS = 1 ELSE THARV.C1 = 3 THARV.C6 = 7 THARV.C8 = 3 TINSOL.SYS = 3 END IF THARV.SILV = 3 OPEN DATA10 FOR RANDOM AS #10 PUT #10, UNIT, THARV CLOSE #10 TTABUU.T = 125 OPEN DATA27 FOR RANDOM AS #27 PUT #27, UNIT, TTABUU CLOSE #27 TINSOL.SILV = 3 OPEN DATA45 FOR RANDOM AS #45 PUT #45, UNIT, TINSOL CLOSE #45 ELSEIF (AGE + 10) > 49 AND (AGE + 10) < 151 AND RIPAR = 1 THEN ' THIN FIRST P = RND IF P < .5 THEN IF SLOPE < 36 THEN THARV.C1 = 5 IF (AGE + 35) < 151 THEN THARV.C4 = 5 IF (AGE + 65) < 151 THEN THARV.C7 = 5 IF (AGE + 95) < 151 THEN THARV.C10 = 5 TINSOL.SYS = 5 ELSE THARV.C1 = 7 IF (AGE + 35) < 151 THEN THARV.C4 = 7 IF (AGE + 65) < 151 THEN THARV.C7 = 7 IF (AGE + 95) < 151 THEN THARV.C10 = 7 TINSOL.SYS = 7 END IF THARV.SILV = 1 OPEN DATA10 FOR RANDOM AS #10 PUT #10, UNIT, THARV CLOSE #10 TTABUU.T = 125 OPEN DATA27 FOR RANDOM AS #27 PUT #27, UNIT, TTABUU CLOSE #27 TINSOL.SILV = 1 OPEN DATA45 FOR RANDOM AS #45 PUT #45, UNIT, TINSOL CLOSE #45 ELSE ' 50- YEAR RETURN INTERVAL IF SLOPE < 36 THEN THARV.C1 = 5 IF (AGE + 60) < 151 THEN THARV.C6 = 5 TINSOL.SYS = 5 ELSE THARV.C1 = 7 IF (AGE + 60) < 151 THEN THARV.C6 = 7 TINSOL.SYS = 7 END IF THARV.SILV = 2 OPEN DATA10 FOR RANDOM AS #10 PUT #10, UNIT, THARV CLOSE #10 TTABUU.T = 125 OPEN DATA27 FOR RANDOM AS #27 PUT #27, UNIT, TTABUU CLOSE #27 TINSOL.SILV = 2 OPEN DATA45 FOR RANDOM AS #45 PUT #45, UNIT, TINSOL CLOSE #45 END IF ELSE OPEN DATA10 FOR RANDOM AS #10 PUT #10, UNIT, THARV CLOSE #10 OPEN DATA27 FOR RANDOM AS #27 PUT #27, UNIT, TTABUU CLOSE #27 END IF ELSE ' IF SPECIES NOT MEADOW OR LODGEPOLE IF (AGE + 10) > 49 AND (AGE + 10) < 151 THEN P = RND IF P > .5 THEN ' TOSS COIN FOR REGIME, 30-YR INTERVAL IF SLOPE < 36 THEN ' GROUND-BASED THARV.C1 = 5 IF (AGE + 40) < 151 THEN THARV.C4 = 5 IF (AGE + 70) < 151 THEN THARV.C7 = 5 IF (AGE + 100) < 151 THEN THARV.C10 = 5 TINSOL.SYS = 5 ELSE THARV.C1 = 7 IF (AGE + 40) < 151 THEN THARV.C4 = 7 IF (AGE + 70) < 151 THEN THARV.C7 = 7 IF (AGE + 100) < 151 THEN THARV.C10 = 7 TINSOL.SYS = 7 END IF THARV.SILV = 1 OPEN DATA10 FOR RANDOM AS #10 PUT #10, UNIT, THARV CLOSE #10 TTABUU.T = 125 OPEN DATA27 FOR RANDOM AS #27 PUT #27, UNIT, TTABUU CLOSE #27 TINSOL.SILV = 1 OPEN DATA45 FOR RANDOM AS #45 PUT #45, UNIT, TINSOL CLOSE #45 ELSE ' 50- YEAR RETURN INTERVAL IF SLOPE < 36 THEN THARV.C1 = 5 IF (AGE + 60) < 151 THEN THARV.C6 = 5 TINSOL.SYS = 5 ELSE THARV.C1 = 7 IF (AGE + 60) < 151 THEN THARV.C6 = 7 TINSOL.SYS = 7 END IF THARV.SILV = 2 OPEN DATA10 FOR RANDOM AS #10 PUT #10, UNIT, THARV CLOSE #10 TTABUU.T = 125 OPEN DATA27 FOR RANDOM AS #27 PUT #27, UNIT, TTABUU CLOSE #27 TINSOL.SILV = 2 OPEN DATA45 FOR RANDOM AS #45 PUT #45, UNIT, TINSOL CLOSE #45 END IF ELSE OPEN DATA10 FOR RANDOM AS #10 PUT #10, UNIT, THARV CLOSE #10 OPEN DATA27 FOR RANDOM AS #27 PUT #27, UNIT, TTABUU CLOSE #27 END IF END IF T = T + 1 ELSE ' IF NOT IN TEMPLIST() OPEN DATA10 FOR RANDOM AS #10 PUT #10, UNIT, THARV ' ALL CHOICES ARE 0 CLOSE #10 OPEN DATA27 FOR RANDOM AS #27 PUT #27, UNIT, TTABUU ' UNIT NOT TABU, INITIALLY CLOSE #27 END IF LOOP ' VERIFIED 10/8/95 CLOSE #1 REM *********************************************************** REM REM END - RANDOM STARTING POINT ALGORITHM ' 9/11/95 REM ' 10/8/95 REM *********************************************************** END SUB SUB ROADCHANGE (FROMNODE, TONODE, PER, STD) REM ************************************************************** REM REM CHANGING ROADTYPE.PRN TO REFLECT A ROAD STANDARD CHANGE REM OCTOBER 27, 1995 REM REM ************************************************************** COLOR 2, 0 PRINT PRINT "ROAD CHANGE" COLOR 7, 0 DIM TLINK AS TLINKS DIM DATA2 AS STRING DATA2 = "C:\PETE\THESIS\MODULES\ROADS.PRN" DIM DATA13 AS STRING DATA13 = "C:\PETE\THESIS\MODULES\ROADTYPE.PRN" LINKS = 0 OPEN DATA2 FOR INPUT AS #2 OPEN DATA13 FOR RANDOM AS #13 DO WHILE NOT EOF(2) INPUT #2, FRND, TND, STD1, LENGTH, GEF, DISSTR, INWS, AVGK, RDSLOPE LINKS = LINKS + 1 IF FRND = FROMNODE AND TND = TONODE THEN GET #13, LINKS, TLINK IF STD = 0 THEN IF PER > 9.1 THEN TLINK.S10 = 0 ELSEIF PER > 8.1 THEN TLINK.S9 = 0 TLINK.S10 = 0 ELSEIF PER > 7.1 THEN TLINK.S8 = 0 TLINK.S9 = 0 TLINK.S10 = 0 ELSEIF PER > 6.1 THEN TLINK.S7 = 0 TLINK.S8 = 0 TLINK.S9 = 0 TLINK.S10 = 0 ELSEIF PER > 5.1 THEN TLINK.S6 = 0 TLINK.S7 = 0 TLINK.S8 = 0 TLINK.S9 = 0 TLINK.S10 = 0 ELSEIF PER > 4.1 THEN TLINK.S5 = 0 TLINK.S6 = 0 TLINK.S7 = 0 TLINK.S8 = 0 TLINK.S9 = 0 TLINK.S10 = 0 ELSEIF PER > 3.1 THEN TLINK.S4 = 0 TLINK.S5 = 0 TLINK.S6 = 0 TLINK.S7 = 0 TLINK.S8 = 0 TLINK.S9 = 0 TLINK.S10 = 0 ELSEIF PER > 2.1 THEN TLINK.S3 = 0 TLINK.S4 = 0 TLINK.S5 = 0 TLINK.S6 = 0 TLINK.S7 = 0 TLINK.S8 = 0 TLINK.S9 = 0 TLINK.S10 = 0 ELSEIF PER > 1.1 THEN TLINK.S2 = 0 TLINK.S3 = 0 TLINK.S4 = 0 TLINK.S5 = 0 TLINK.S6 = 0 TLINK.S7 = 0 TLINK.S8 = 0 TLINK.S9 = 0 TLINK.S10 = 0 ELSE TLINK.S1 = 0 TLINK.S2 = 0 TLINK.S3 = 0 TLINK.S4 = 0 TLINK.S5 = 0 TLINK.S6 = 0 TLINK.S7 = 0 TLINK.S8 = 0 TLINK.S9 = 0 TLINK.S10 = 0 END IF ELSE IF PER = 1 THEN TLINK.S1 = STD IF PER = 2 THEN TLINK.S2 = STD IF PER = 3 THEN TLINK.S3 = STD IF PER = 4 THEN TLINK.S4 = STD IF PER = 5 THEN TLINK.S5 = STD IF PER = 6 THEN TLINK.S6 = STD IF PER = 7 THEN TLINK.S7 = STD IF PER = 8 THEN TLINK.S8 = STD IF PER = 9 THEN TLINK.S9 = STD IF PER = 10 THEN TLINK.S10 = STD END IF PUT #13, LINKS, TLINK GOTO CUSTER END IF LOOP CUSTER: CLOSE #2 CLOSE #13 PRINT " Finished Changing Road Standards" REM ************************************************************** REM REM END - CHANGING ROADTYPE.PRN TO REFLECT A ROAD STANDARD CHANGE REM REM ************************************************************** END SUB SUB ROADUSE (UCOUNT, LINKS, UNIT, HSYS(), CUT(), PCUT(), PLUSMINUS) REM ****************************************************** REM REM Road Use Algorithm REM DECEMBER 10, 1995 REM Pete Bettinger REM REM ****************************************************** PRINT " Invoking ROAD USE ALGORITHM" DIM TENTRY AS TENTRYNODE DIM THARV AS THARVESTC DIM TCUT AS TCUTVOL DIM TUSE AS TROADUSE DIM DATA4 AS STRING ' DATA FILE PATHS.prn DATA4 = "C:\PETE\THESIS\MODULES\PATHS.PRN" DIM DATA42 AS STRING DATA42 = "C:\PETE\THESIS\MODULES\ENTRYRND.PRN" DIM DATA47 AS STRING DATA47 = "C:\PETE\THESIS\MODULES\ROADUSE.PRN" DIM CC AS STRING ' USED TO BREAK THE PROGRAM DIM PERIOD AS SINGLE ' USED IN PART 1, PERIOD OF HARVEST DIM SYS(10) AS SINGLE ' USED IN PART 1, HARVEST SYSTEM DIM USE(10) AS SINGLE ' USED IN PART 1, ROAD USE DIM START AS SINGLE ' USED IN PART 1, START NODE DIM TERMINUS AS SINGLE ' USED IN PART 1, TERMINUS DIM NODE3 AS SINGLE ' USED IN PART 1, ENTRY NODE DIM NODE4 AS SINGLE ' USED IN PART 1, ENTRY NODE DIM FROMNODE AS SINGLE ' USED IN PART 1, FROM NODE DIM TONODE AS SINGLE ' USED IN PART 1, TO NODE DIM NUMNODES AS SINGLE ' USED IN PART 1, NUMBER OF NODES DIM LENGTH AS SINGLE ' USED IN PART 1, LENGTH OF LINK REM **************************************** REM REM DETERMINING ROAD USE REM REM **************************************** PRINT " Determining Road Use" FOR I = 1 TO 10 ' FOR EACH PERIOD IF HSYS(I) > 0 THEN ' IF A HARVEST OCCURS W = (((HSYS(I) - 1) * UCOUNT) + UNIT) OPEN DATA42 FOR RANDOM AS #42 GET #42, W, TENTRY NODE3 = TENTRY.E CLOSE #42 OPEN DATA4 FOR INPUT AS #4 ' OPEN PATHS.prn DO WHILE NOT EOF(4) INPUT #4, START, TERMINUS, PERIOD, SED, NUMNODES, LENGTH IF PERIOD = I AND NODE3 = TERMINUS THEN ' IF PERIODS AND NODES INPUT #4, FROMNODE ' MATCH, ENTER A FROMNODE FOR J = 1 TO (NUMNODES - 1) INPUT #4, TONODE ' ENTER A TO-NODE OPEN DATA47 FOR RANDOM AS #47 FOR G = 1 TO LINKS GET #47, G, TUSE IF (TUSE.X = FROMNODE AND TUSE.Y = TONODE) OR (TUSE.X = TONODE AND TUSE.Y = FROMNODE) THEN IF I = 1 THEN USE = TUSE.U1 IF I = 2 THEN USE = TUSE.U2 IF I = 3 THEN USE = TUSE.U3 IF I = 4 THEN USE = TUSE.U4 IF I = 5 THEN USE = TUSE.U5 IF I = 6 THEN USE = TUSE.U6 IF I = 7 THEN USE = TUSE.U7 IF I = 8 THEN USE = TUSE.U8 IF I = 9 THEN USE = TUSE.U9 IF I = 10 THEN USE = TUSE.U10 IF PLUSMINUS = 1 THEN USE = USE + CUT(I) - PCUT(I) ELSE USE = USE - CUT(I) + PCUT(I) END IF IF I = 1 THEN TUSE.U1 = USE IF I = 2 THEN TUSE.U2 = USE IF I = 3 THEN TUSE.U3 = USE IF I = 4 THEN TUSE.U4 = USE IF I = 5 THEN TUSE.U5 = USE IF I = 6 THEN TUSE.U6 = USE IF I = 7 THEN TUSE.U7 = USE IF I = 8 THEN TUSE.U8 = USE IF I = 9 THEN TUSE.U9 = USE IF I = 10 THEN TUSE.U10 = USE PUT #47, G, TUSE EXIT FOR END IF NEXT G CLOSE #47 FROMNODE = TONODE ' MAKE THE FROMNODE THE NEXT J ' CURRENT TO NODE GOTO BACKROAD ' EXIT PATHS.prn EARLY ELSE FOR J = 1 TO NUMNODES ' SPOOLING THROUGH BOGUS NODES INPUT #4, NODE4 NEXT J END IF LOOP BACKROAD: ' EXIT PATHS.prn EARLY CLOSE #4 ' CLOSE PATHS.prn END IF ' IF HARVEST OCCURS ENDIF NEXT I ' NEXT PERIOD PRINT " Finished Calculating Road Use" REM ****************************************************** REM REM END - Determining Road Use ' VERIFIED 12/10/95 REM REM ****************************************************** END SUB SUB SAVEBEST (B, UCOUNT, LINKS, RUNNM$) REM ******************************************************* REM REM SAVING BEST HARVEST.PRN AND ROADTYPE.PRN REM REM ******************************************************* COLOR 2, 0 PRINT PRINT "SAVING THIS SOLUTION - BEST SO FAR" COLOR 7, 0 DIM TCUT AS TCUTVOL DIM THARV AS THARVESTC DIM TLINK AS TLINKS DIM TTABUU AS TTABUUNIT DIM TTABUR AS TTABUROAD DIM TINSOL AS TINSOLUTION DIM TUSE AS TROADUSE DIM DATA2 AS STRING DATA2 = "C:\PETE\THESIS\MODULES\ROADS.PRN" DIM DATA10 AS STRING DATA10 = "C:\PETE\THESIS\MODULES\HARVEST.PRN" DIM DATA13 AS STRING DATA13 = "C:\PETE\THESIS\MODULES\ROADTYPE.PRN" DIM DATA16 AS STRING DATA16 = "C:\PETE\THESIS\MODULES\CUT.PRN" DIM DATA30 AS STRING DATA30 = "C:\PETE\THESIS\MODULES\BESTCUT.PRN" DIM DATA32 AS STRING DATA32 = "C:\PETE\THESIS\MODULES\BESTHARV.PRN" DIM DATA33 AS STRING DATA33 = "C:\PETE\THESIS\MODULES\BESTROAD.PRN" OPEN DATA16 FOR RANDOM AS #16 ' SAVING HARVEST VOLUMES OPEN DATA30 FOR OUTPUT AS #30 PRINT #30, RUNNM$, DATE$, TIME$ PRINT #30, "ITERATION "; B FOR I = 2 TO UCOUNT GET #16, I, TCUT PRINT #30, I; TCUT.SP; TCUT.C1; TCUT.C2; TCUT.C3; TCUT.C4; TCUT.C5; TCUT.C6; TCUT.C7; TCUT.C8; TCUT.C9; TCUT.C10 NEXT I CLOSE #16 CLOSE #30 OPEN DATA10 FOR RANDOM AS #10 ' SAVING UNIT CHOICES OPEN DATA32 FOR OUTPUT AS #32 PRINT #32, RUNNM$, DATE$, TIME$ PRINT #32, "ITERATION "; B FOR I = 2 TO UCOUNT GET #10, I, THARV PRINT #32, I; THARV.SILV; THARV.C1; THARV.C2; THARV.C3; THARV.C4; THARV.C5; THARV.C6; THARV.C7; THARV.C8; THARV.C9; THARV.C10 NEXT I CLOSE #10 CLOSE #32 OPEN DATA2 FOR INPUT AS #2 OPEN DATA13 FOR RANDOM AS #13 ' SAVING ROAD CHOICES OPEN DATA33 FOR OUTPUT AS #33 PRINT #33, RUNNM$, DATE$, TIME$ PRINT #33, "ITERATION "; B FOR I = 1 TO LINKS INPUT #2, FRN, TN, STD, L, GEF, DUSSTR, INWS, AVGK, RDSLOPE GET #13, I, TLINK PRINT #33, FRN; TN; L; TLINK.S1; TLINK.S2; TLINK.S3; TLINK.S4; TLINK.S5; TLINK.S6; TLINK.S7; TLINK.S8; TLINK.S9; TLINK.S10 NEXT I CLOSE #2 CLOSE #13 CLOSE #33 PRINT " Finished Saving the Best Solution" REM ******************************************************* REM REM END - SAVING BEST HARVEST.PRN AND ROADTYPE.PRN REM REM ******************************************************* END SUB SUB SHADOW (W(), ITER) ' W() = TEMPERATURE REM ********************************************************************* REM REM SHADOW Stream Temperature Model REM December 13, 1995 REM REM PETE BETTINGER REM REM This model provides a simple, quantitative means of estimating REM the impact of streamside vegetation removal on stream temperature. REM This model uses George Brown's temperature prediction model, and REM the key element is the amount of unshaded stream. REM REM SHADOW was developed as a "front-end" to Brown's equations, to help REM in estimating the amount of unshaded stream, and stream temperature. REM REM USDA Forest Service. 1993. SHADOW stream temperature management REM program user's manual, version 2.3. USDA Forest Service, Pacific REM Northwest Region, Portland, OR. 20 p. REM REM REM Three major parts to the program: REM 1. Solar Model REM 2. Shade Model REM 3. Stream Temperature Model REM REM ********************************************************************* REM COMMENTS: REM REM 1. Finished Part 1 - Solar Model, and Reports REM 2. Finished Part 2 - Shade Model, and Reports REM 3. Finished Part 3 - Stream Temperature, and Reports REM REM 4. Improve Flow Widths / class REM REM ********************************************************************* COLOR 2, 0 PRINT PRINT "STREAM TEMPERATURE MODELING, using SHADOW and Brown's Equation" COLOR 7, 0 DIM THARV AS THARVESTC DIM THT AS THEIGHTS DIM TSTREAM AS TSTREAMUNIT DIM DATA3 AS STRING ' USED IN PART 1, STREAMS.prn DATA3 = "C:\PETE\THESIS\MODULES\STREAMS.PRN" DIM DATA10 AS STRING ' USED IN PART 2, HARVEST.prn DATA10 = "C:\PETE\THESIS\MODULES\HARVEST.PRN" DIM DATA15 AS STRING ' USED IN PART 2, HEIGHT.prn DATA15 = "C:\PETE\THESIS\MODULES\HEIGHT.PRN" DIM DATA22 AS STRING DATA22 = "C:\PETE\THESIS\MODULES\CANDIDAT.PRN" DIM DATA29 AS STRING DATA29 = "C:\PETE\THESIS\MODULES\STRMUNIT.PRN" DIM CC AS STRING ' USED EVERYWHERE DIM GWTEMP AS SINGLE ' USED IN PART 3, GROUND WATER TEMPERATURE DIM HEATRATE AS SINGLE ' USED IN PART 3, HEAT RATE DIM LATITUDE AS SINGLE ' USED IN PART 1, LATITUDE OF STUDY AREA LATITUDE = 45 ' DEGREES, EASTERN OREGON, WEST OF LaGRANDE DIM DECLINATION AS SINGLE ' USED IN PART 1, DECLINATION OF STUDY AREA DECLINATION = 19 ' DEGREES, EASTERN OREGON, WEST OF LaGRANDE DIM HOUR(9) AS SINGLE ' USED IN PART 1, HOURS OF THE DAY FOR ANALYSIS HOUR(1) = 8 ' MILITARY TIME HOUR(2) = 9 HOUR(3) = 10 HOUR(4) = 11 HOUR(5) = 12 HOUR(6) = 13 HOUR(7) = 14 HOUR(8) = 15 HOUR(9) = 16 DIM HOURDEG(9) AS SINGLE ' USED IN PART 1, HOUR DEGREES HOURDEG(1) = -60 ' FROM SHADOW PROGRAM HOURDEG(2) = -45 HOURDEG(3) = -30 HOURDEG(4) = -15 HOURDEG(5) = 0 HOURDEG(6) = 15 HOURDEG(7) = 30 HOURDEG(8) = 45 HOURDEG(9) = 60 DIM HOURRAD(9) AS SINGLE ' USED IN PART 1, HOUR RADIANS DIM ZENRAD(9) AS SINGLE ' USED IN PART 1, ZENITH RADIANS DIM ZENDEG(9) AS SINGLE ' USED IN PART 1, ZENITH DEGREES DIM AZRAD(9) AS SINGLE ' USED IN PART 1, AZIMUTH RADIANS DIM AZDEG(9) AS SINGLE ' USED IN PART 1, AZIMUTH DEGREES DIM Y1 AS SINGLE ' USED IN PART 1, TEMPORARY VARIABLE DIM Y2 AS SINGLE ' USED IN PART 1, TEMPORARY VARIABLE DIM Y3 AS SINGLE ' USED IN PART 1, TEMPORARY VARIABLE DIM Y4 AS SINGLE ' USED IN PART 1, TEMPORARY VARIABLE DIM UPSTRM AS SINGLE ' USED IN PART 2, UPSTREAM NODE DIM DNSTRM AS SINGLE ' USED IN PART 2, DOWNSTREAM NODE DIM STRMLN AS SINGLE ' USED IN PART 2, STREAM LENGTH DIM STRMORIENT AS SINGLE ' USED IN PART 2, STREAM ORIENTATION (DEGREES) DIM STRMOR AS SINGLE ' USED IN PART 2, STREAM ORDER (RADIANS) DIM SHADANG(9) AS SINGLE ' USED IN PART 2, SHADOW ANGLE DIM LSHADOW(9) AS SINGLE ' USED IN PART 2, LENGTH OF SHADOW DIM POLY AS SINGLE ' USED IN PART 2, POLYGON AT STREAM DIM TREEHT(10) AS SINGLE ' USED IN PART 2, TREE HEIGHT DIM SLOPE AS SINGLE ' USED IN PART 2, TERRAIN (GROUND) SLOPE DIM TREECHDIST AS SINGLE ' USED IN PART 2, TREE CHANNEL DISTANCE DIM LSHADOWCR(9) AS SINGLE ' USED IN PART 2, LENGTH OF SHADOW TOWARDS CREEK DIM SHADOW1(9) AS SINGLE ' USED IN PART 2, TEMPORARY VARIABLE DIM CLASS AS SINGLE ' USED IN PART 2, STREAM CLASS DIM SHDENSITY AS SINGLE ' USED IN PART 2, SHADE DENSITY DIM ACW(5) AS SINGLE ' USED IN PART 2, ACTIVE CHANNEL WIDTH DIM DWS(9) AS SINGLE ' USED IN PART 2, DENSITY/WIDTH*SHADOW DIM CDWS(9) AS SINGLE ' USED IN PART 2, CORRECTION TO DWS DIM SOLAR(9) AS SINGLE ' USED IN PART 2, SOLAR VALUES SOLAR(1) = 5 ' SOLAR VALUES SOLAR(2) = 7 SOLAR(3) = 9 SOLAR(4) = 12 SOLAR(5) = 12 SOLAR(6) = 12 SOLAR(7) = 9 SOLAR(8) = 7 SOLAR(9) = 5 DIM TSRAD(9) AS SINGLE ' USED IN PART 2, TOTAL SOLAR RADIATION (HOURLY) DIM PUNSHADE(9) AS SINGLE ' USED IN PART 2, PERCENT UNSHADED DIM OVERHANG AS SINGLE ' USED IN PART 2, PERCENT TREE OVERHANG DIM PUNSHADERAD(9) AS SINGLE ' USED IN PART 2, PERCENT UNSHADED RADIATION DIM SUM AS SINGLE ' USED IN PART 2, TEMPORARY VARIABLE DIM UNSHADE AS SINGLE ' USED IN PART 2, PERCENT UNSHADED STREAM DIM PTREEREM AS SINGLE ' USED IN PART 2, PART OF TREE REMOVED DIM LOGCLEAR AS SINGLE ' USED IN PART 2, LOG CLEARANCE OVER STREAM DIM TOTSOLRAD AS SINGLE ' USED IN PART 2, TOTAL SOLAR RADIATION (DAILY) DIM SKYWIDTH AS SINGLE ' USED IN PART 2, SKYROAD WIDTH DIM NOSKYRDS AS SINGLE ' USED IN PART 2, NUMBER OF SKYROADS DIM CREMSKY AS SINGLE ' USED IN PART 2, CANOPY REMOVED - SKYROAD DIM UNSTRMSKY AS SINGLE ' USED IN PART 2, UNSHADED STREAM - SKYROAD DIM CREMHAR(8) AS SINGLE ' USED IN PART 2, CANOPY REMOVED - HARVEST DIM UNSTRMHAR AS SINGLE ' USED IN PART 2, UNSHADED STREAM - HARVEST DIM MAXHAR AS SINGLE ' USED IN PART 2, MAXIMUM HARVEST IN RMA DIM Y5 AS SINGLE ' USED IN PART 2, TEMPORARY VARIABLE DIM SYS(10) AS SINGLE ' USED IN PART 2, LOGGING SYSTEM DIM TOTUNSHADE AS SINGLE ' USED IN PART 2, TOTAL UNSHADED STREAM DIM TEMPINC AS SINGLE ' USED IN PART 3, TEMPERATURE INCREASE - REACH DIM STRMAREA AS SINGLE ' USED IN PART 3, STREAM AREA DIM SUMSTRMAREA AS SINGLE ' USED IN PART 3, SUM OF STREAM AREAS DIM BRTEMP AS SINGLE ' USED IN PART 3, BROWN'S EQUATION FOR TOTAL FLOW DIM TEMPERATURE AS SINGLE ' USED IN PART 3, TEMP INCREASE + GROUND WATER DIM TEMP(10) AS SINGLE ' USED IN PART 3, TEMP FOR PERIOD K REM ************** IMPORTANT ASSUMPTIONS **************************** GWTEMP = 49 ' 49 DEGREES IN JUNE-AUGUST, WS85 HEATRATE = 3.5 ' BTU/ftsq-min ACW(1) = 38.21 ' ACTIVE CHANNEL WIDTHS ACW(2) = 4.09 ACW(3) = 1 ACW(4) = 0 ACW(5) = 0 LOGCLEAR = 15 ' LOG CLEARANCE OVER STREAM SKYWIDTH = 10 ' SKYROAD WIDTH CREMHAR(0) = 0 ' NO HARVEST IN RIPARIAN AREA CREMHAR(1) = 1 ' MAX CANOPY REMOVED - CC - TRACTOR CREMHAR(2) = 1 ' MAX CANOPY REMOVED - CC - CABLE CREMHAR(3) = 1 ' MAX CANOPY REMOVED - CC - SKYLINE CREMHAR(4) = 1 ' MAX CANOPY REMOVED - CC - AERIAL CREMHAR(5) = .33 ' MAX CANOPY REMOVED - PARTIAL CUT - TRACTOR CREMHAR(6) = .33 ' MAX CANOPY REMOVED - PARTIAL CUT - CABLE CREMHAR(7) = .33 ' MAX CANOPY REMOVED - PARTIAL CUT - SKYLINE CREMHAR(8) = .33 ' MAX CANOPY REMOVED - PARTIAL CUT - AERIAL DIM LOWFLOW(5) AS SINGLE ' USED IN PART 3, LOW FLOW LOWFLOW(1) = 39 ' LOW FLOW - REAL FOR CLASS I (cfs) LOWFLOW(2) = 1 ' ESTIMATED FOR CLASS II LOWFLOW(3) = .06 ' ESTIMATED FOR CLASS III LOWFLOW(4) = 0 ' BOGUS LOW FLOW, CLASS IV LOWFLOW(5) = 0 ' BOGUS LOW FLOW, CLASS V DIM FLOWWD(5) AS SINGLE ' USED IN PART 3, FLOW WIDTH FOR I = 1 TO 5 IF LOWFLOW(I) > 0 AND LOWFLOW(I) < .16 THEN FLOWWD(I) = 12.5 * LOWFLOW(I) IF LOWFLOW(I) > .16 AND LOWFLOW(I) < .5 THEN FLOWWD(I) = 1.55 + 2.84 * LOWFLOW(I) IF LOWFLOW(I) > .5 AND LOWFLOW(I) < .98 THEN FLOWWD(I) = 2.3 + 1.37 * LOWFLOW(I) IF LOWFLOW(I) > .98 AND LOWFLOW(I) < 1.7 THEN FLOWWD(I) = 3.1 + .56 * LOWFLOW(I) IF LOWFLOW(I) > 1.7 THEN FLOWWD(I) = 2.75 + .76 * LOWFLOW(I) NEXT I DIM VEY AS SINGLE ' SUM OF STREAM AREA AT VEY MEADOWS TO GET VEY = 82823.66 ' THE TEMPERATURE OBSERVED AT VEY MEADOWS ' TO GET 50.8 DEGREES AVG 5-DAY MINIMUM TEMP REM ********************************************* REM Part 0. Possible By-Pass REM ********************************************* REM OPEN DATA22 FOR INPUT AS #22 INPUT #22, UNIT, SILV, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 CLOSE #22 OPEN DATA29 FOR RANDOM AS #29 GET #29, UNIT, TSTREAM CLOSE #29 IF ITER > 1 AND TSTREAM.U = 0 THEN PRINT " SHADOW: Part 0. CANDIDATE DOES NOT AFFECT STREAM TEMPERATURE " GOTO OWENSBORO END IF REM ********************************************* REM Part 1. Solar Model REM ********************************************* REM REM Solar physics equations from Quigley (1981) are used to develop REM the hour angles from 8AM-4PM on August 1, the zenith and azimuth REM angle for each hour are calculated from these equations. REM REM Inputs: latitude, declination REM Outputs: zenith angle, azimuth angle REM REM Quigley, T.M. 1981. Estimating contribution of overstory vegetation REM to stream surface shade. Wildlife Society Bulletin. 9(1):22-27. REM REM REM Output ready: HOUR(9); HOURDEG(9); HOURRAD(9) <= HOURS REM ZENDEG(9); ZENRAD(9) <= ZENITH REM AZDEG(9); AZRAD(9) <= AZIMUTH REM REM ONLY PERFORMED ONCE, NOT FOR EACH STREAM, NOR EACH PERIOD REM PRINT " SHADOW: Part 1. SOLAR MODEL " FOR I = 1 TO 9 ' CALCULATING HOUR RADIANS HOURRAD(I) = HOURDEG(I) * .0174533# NEXT I ' VERIFIED 7/3/95 FOR I = 1 TO 9 ' CALCULATING ZENITH RADIANS Y1 = SIN(LATITUDE * .0174533#) * SIN(DECLINATION * .0174533) Y2 = COS(DECLINATION * .0174533#) * COS(LATITUDE * .0174533) * COS(HOURRAD(I)) Y3 = Y1 + Y2 ZENRAD(I) = 1.570796 - ATN(Y3 / (SQR(1 - (Y3 ^ 2)))) NEXT I ' VERIFIED 7/3/95 FOR I = 1 TO 9 ' CALCULATING ZENITH DEGREES ZENDEG(I) = ZENRAD(I) * 57.295755# NEXT I ' VERIFIED 7/3/95 FOR I = 1 TO 9 ' CALCULATING AZIMUTH RADIANS Y4 = COS(DECLINATION * .0174533) * SIN(HOURRAD(I)) / SIN(ZENRAD(I)) AZRAD(I) = ATN(Y4 / (SQR(1 - (Y4 ^ 2)))) NEXT I ' VERIFIED 7/3/95 FOR I = 1 TO 9 ' CALCULATING AZIMUTH DEGREES AZDEG(I) = AZRAD(I) * 57.295755# NEXT I ' VERIFIED 7/3/95 REM ********************************************* REM Part 2. Shade Model REM ********************************************* REM REM The stream shade equations calculate: the amount of unshaded stream, REM harvest prescription, and riparian width REM REM Inputs: zenith angle, azimuth angle, active channel width, tree height, REM terrain slope, stream orientation, tree channel distance, shade REM density, percent canopy removed during harvest, skyroad width, REM number of skyroads, log suspension height REM REM Outputs: percent unshaded stream, percent unshaded stream from skyroads, REM percent unshaded stream from harvest, total unshaded stream REM PRINT " SHADOW: Part 2. SHADE MODEL, for each stream, over 10 periods" OPEN DATA3 FOR INPUT AS #3 ' DETERMINING HOW MANY STREAMS ARE IN THE COUNT = 0 ' FILE "STREAMS.PRN" DO WHILE NOT EOF(3) INPUT #3, UPSTRM, DNSTRM, CLASS, STRMLN, STRMORIENT, TREEHT, SLOPE, TREECHDIST, SHADEDENSITY, OVERHANG COUNT = COUNT + 1 ' TOTAL NUMBER OF STREAMS = COUNT LOOP CLOSE #3 ' VERIFIED 7/3/95 FOR K = 1 TO 10 ' FOR EACH PERIOD OPEN DATA3 FOR INPUT AS #3 FOR I = 1 TO COUNT ' FOR EACH STREAM INPUT #3, UPSTRM, DNSTRM, CLASS, STRMLN, STRMORIENT, POLY, SLOPE, TREECHDIST, SHADEDENSITY, OVERHANG IF CLASS > 3 THEN GOTO IOWA ' IF NOT CLASS 1-3 GET ANOTHER STREAM SLOPE = SLOPE / 100 ' NEEDS TO BE DECIMAL PERCENT SLOPE SHADEDENSITY = SHADEDENSITY / 100 ' NEEDS TO BE DECIMAL SHADE DENSITY OVERHANG = OVERHANG / 100 ' NEEDS TO BE DECIMAL PERCENT TREE OVERHANG OPEN DATA15 FOR RANDOM AS #15 ' GET TREE HEIGHTS GET #15, POLY, THT TREEHT(1) = THT.H1 TREEHT(2) = THT.H2 TREEHT(3) = THT.H3 TREEHT(4) = THT.H4 TREEHT(5) = THT.H5 TREEHT(6) = THT.H6 TREEHT(7) = THT.H7 TREEHT(8) = THT.H8 TREEHT(9) = THT.H9 TREEHT(10) = THT.H10 CLOSE #15 OPEN DATA10 FOR RANDOM AS #10 ' GET LOGGING SYSTEMS GET #10, POLY, THARV SILV = THARV.SILV SYS(1) = THARV.C1 SYS(2) = THARV.C2 SYS(3) = THARV.C3 SYS(4) = THARV.C4 SYS(5) = THARV.C5 SYS(6) = THARV.C6 SYS(7) = THARV.C7 SYS(8) = THARV.C8 SYS(9) = THARV.C9 SYS(10) = THARV.C10 CLOSE #10 IF SYS(K) = 6 OR SYS(K) = 7 THEN ' IF PARTIAL CUTTING WITH CABLE SYS THEN NOSKYRDS = INT(STRMLN / 100) ' NUMBER OF SKYROADS = LENGTH / 100 FT SHDENSITY = SHADEDENSITY * .8 ELSEIF SYS(K) = 5 OR SYS(K) = 8 THEN SHDENSITY = SHADEDENSITY * .8 ELSEIF SYS(K) < 5 THEN ' ELSE SHDENSITY = SHADEDENSITY NOSKYRDS = 0 ' NUMBER OF SKYROADS = 0 END IF ' VERIFIED 7/22/95 STRMOR = STRMORIENT * .0174533 FOR J = 1 TO 9 SHADANG(J) = SIN(AZRAD(J) - STRMOR) NEXT J ' VERIFIED 7/3/95 FOR J = 1 TO 9 LSHADOW(J) = TAN(ZENRAD(J)) * (TREEHT(K) + SLOPE * TREECHDIST) NEXT J ' VERIFIED 7/4/95 FOR J = 1 TO 9 LSHADOWCR(J) = ABS(SHADANG(J) * LSHADOW(J)) NEXT J ' VERIFIED 7/4/95 FOR J = 1 TO 9 IF TREECHDIST > LSHADOWCR(J) THEN SHADOW1(J) = 0 ELSE SHADOW1(J) = (LSHADOWCR(J) - TREECHDIST) END IF NEXT J ' VERIFIED 7/4/95 FOR J = 1 TO 9 DWS(J) = (SHADOW1(J) * SHDENSITY / ACW(CLASS)) NEXT J ' VERIFIED 7/4/95 FOR J = 1 TO 9 IF DWS(J) > 1 THEN CDWS(J) = 1 ELSE CDWS(J) = DWS(J) END IF NEXT J ' VERIFIED 7/4/95 FOR J = 1 TO 9 TSRAD(J) = SOLAR(J) / 100 NEXT J ' VERIFIED 7/4/95 FOR J = 1 TO 9 PUNSHADE(J) = 1 - CDWS(J) NEXT J ' VERIFIED 7/4/95 FOR J = 1 TO 9 IF PUNSHADE(J) = 1 THEN PUNSHADERAD(J) = (1 - (.8 * OVERHANG)) * TSRAD(J) ELSE PUNSHADERAD(J) = TSRAD(J) * PUNSHADE(J) IF PUNSHADERAD(J) > ((1 - (.8 * OVERHANG)) * TSRAD(J)) THEN PUNSHADERAD(J) = ((1 - (.8 * OVERHANG)) * TSRAD(J)) END IF END IF NEXT J ' VERIFIED 7/4/95 SUM = 0 'PRINT PUNSHADERAD(1); PUNSHADERAD(2); PUNSHADERAD(3); PUNSHADERAD(4); PUNSHADERAD(5); PUNSHADERAD(6); PUNSHADERAD(7); PUNSHADERAD(8); PUNSHADERAD(9) FOR J = 1 TO 9 SUM = SUM + PUNSHADERAD(J) NEXT J ' CALCULATING % UNSHADED STREAM 'PRINT USING "SUM #####.##### OVERHANG #####.#####"; SUM; OVERHANG UNSHADE = SUM * (1 - (OVERHANG / 100) * .8) ' VERIFIED 7/4/95 IF TREEHT(K) > 0 THEN PTREEREM = (TREEHT(K) - LOGCLEAR) / (TREEHT(K) / 2) ' PART OF TREE REMOVED ELSE PTREEREM = .01 END IF IF PTREEREM > 1 THEN PTREEREM = 1 IF PTREEREM < 0 THEN PTREEREM = .01 ' VERIFIED 7/4/95 TOTSOLRAD = 0 FOR J = 1 TO 9 TOTSOLRAD = TOTSOLRAD + TSRAD(J) NEXT J ' VERIFIED 7/4/95 CREMSKY = (SKYWIDTH * NOSKYRDS / STRMLN * PTREEREM) ' CANOPY REMOVED - SKYLINE ' VERIFIED 7/4/95 UNSTRMSKY = (TOTSOLRAD - UNSHADE) * CREMSKY ' UNSHADED STREAM - SKYROAD ' VERIFIED 7/4/95 MAXHAR = (1 / (1 + CREMSKY)) IF CREMHAR(SYS(K)) > MAXHAR THEN ' SYS = SYSTEM, DEFAULT = NO CUT Y5 = MAXHAR ELSE Y5 = CREMHAR(SYS(K)) END IF UNSTRMHAR = (TOTSOLRAD - UNSHADE) * Y5 ' VERIFIED 7/4/95 'PRINT USING "UNSHADE #####.##### UNSTRMSKY #####.##### UNSTRMHAR #####.#####"; UNSHADE; UNSTRMSKY; UNSTRMHAR TOTUNSHADE = (UNSHADE + UNSTRMSKY + UNSTRMHAR) REM ********************************************* REM Part 3. Stream Temperature REM ********************************************* REM REM The stream temperature model calcualtes the 5-day average maximum REM summer stream temperature. REM REM Inputs: total unshaded stream, stream width, stream length, low flow. REM REM Outputs: stream temperature REM TEMPINC = (STRMLN * FLOWWD(CLASS) * TOTUNSHADE * HEATRATE * .000267 / LOWFLOW(CLASS)) ' TEMPERATURE INCREASE - VERIFIED 7/4/95 STRMAREA = (STRMLN * FLOWWD(CLASS) * TOTUNSHADE) ' VERIFIED 7/5/95 SUMSTRMAREA = SUMSTRMAREA + STRMAREA BRTEMP = (VEY + SUMSTRMAREA) * HEATRATE * .000267 / LOWFLOW(CLASS) ' VERIFIED 7/5/95 TEMPERATURE = GWTEMP + BRTEMP 'PRINT USING "#### ######.## ###.## #.### ###,###,###.##"; I; STRMLN; FLOWWD(CLASS); TOTUNSHADE; SUMSTRMAREA 'CC = INPUT$(1) IOWA: ' WHERE PROGRAM IS SENT IF CLASS>3 OR NOT RIPAR UNIT NEXT I ' NEXT STREAM LINK, PLEASE 'PRINT USING "TOTAL UNSHADED STREAM AREA ###,###,###.##"; SUMSTRMAREA CLOSE #3 TEMP(K) = TEMPERATURE ' TEMPERATURE IN PERIOD K = TEMPERATURE SUMSTRMAREA = 0 ' SETTING SUM OF STREAM AREA UNSHADED BACK TO 0 NEXT K ' NEXT PERIOD, PLEASE FOR I = 1 TO 10 W(I) = TEMP(I) NEXT I OWENSBORO: PRINT " SHADOW: Part 3. STREAM TEMPERATURE, for 10 periods" PRINT FOR K = 1 TO 10 PRINT USING " Stream Temperature at Critical Point, Period ## is ###.# degrees F."; K; W(K) NEXT K 'CC = INPUT$(1) REM ********************************************************************* REM REM END - SHADOW STREAM TEMPERATURE MODEL ' COMPLETED 8/10/95 REM REM ********************************************************************* END SUB SUB TABUTESTR (FROMNODE, TONODE, V, LINKS) ' V = TABU (1=YES, 0=NO) REM ******************************************************** REM REM TESTING ROAD TO SEE IF IT IS TABU REM REM ******************************************************** COLOR 2, 0 PRINT PRINT "TABU TEST - ROADS" COLOR 7, 0 DIM TTABUR AS TTABUROAD DIM DATA28 AS STRING DATA28 = "C:\PETE\THESIS\MODULES\TABUROAD.PRN" V = 1 ' INITIAL ASSUMPTION - TABU (=1) OPEN DATA28 FOR RANDOM AS #28 ' OPEN TABUROAD.PRN FOR I = 1 TO LINKS GET #28, I, TTABUR IF FROMNODE = TTABUR.X AND TONODE = TTABUR.Y THEN ' WHEN NODES ARE EQUAL IF TTABUR.T = 0 THEN V = 0 ' IF NOT TABU, V = 0 GOTO GETOUT2 END IF NEXT I GETOUT2: CLOSE #28 IF V = 0 THEN PRINT " Road Choice is not TABU" IF V = 1 THEN PRINT " Road Choice is TABU" REM ******************************************************** REM REM END - TESTING CANDIDATE TO SEE IF IT IS TABU REM REM ******************************************************** END SUB SUB TABUTESTU (V, D, UCOUNT) ' V = TABU (0=YES, 1=NO), D = TESTNPV REM ******************************************************** REM REM TESTING CANDIDATE TO SEE IF IT IS TABU REM REM ******************************************************** COLOR 2, 0 PRINT PRINT "TABU TEST - UNITS" COLOR 7, 0 DIM TTABUU AS TTABUUNIT DIM DATA22 AS STRING DATA22 = "C:\PETE\THESIS\MODULES\CANDIDAT.PRN" DIM DATA27 AS STRING DATA27 = "C:\PETE\THESIS\MODULES\TABUUNIT.PRN" OPEN DATA22 FOR INPUT AS #22 INPUT #22, UNIT CLOSE #22 V = 1 ' TEMPORARILY ACCEPT CANDIDATE OPEN DATA27 FOR RANDOM AS #27 ' OPEN TABUUNIT.PRN GET #27, UNIT, TTABUU ' INPUT UNIT, TABU STATE IF TTABUU.T > 0 THEN ' IF TABU IF D = 1 THEN ' IS NPV BEST (D=1?) V = 2 ' THEN CANDIDATE MEETS ASPIRATION CRIT. ELSE ' AND CHOICE CAN GO FORWARD V = 0 ' IF NOT, UNIT CHOICE TO BE REJECTED END IF END IF CLOSE #27 IF V = 0 THEN PRINT " Unit Choice is TABU" IF V = 1 THEN PRINT " Unit Choice is not TABU" IF V = 2 THEN PRINT " Unit Choice is TABU, but meets aspiration criteria" V = 1 END IF REM ******************************************************** REM REM END - TESTING CANDIDATE TO SEE IF IT IS TABU REM REM ******************************************************** END SUB SUB UNITCHOICE (H, Y, E, F, G) ' H= BESTNPV, Y = BESTPERIOD, E = BESTUNIT ' F = BESTSILV, G = BESTSYS REM ************************************************************ REM REM CHOOSING A UNIT TO ENTER THE SOLUTION AS A CANDIDATE REM NOVEMBER 6, 1995 REM PETE BETTINGER REM REM ************************************************************ COLOR 2, 0 PRINT PRINT "CHOOSING A CANDIDATE UNIT" COLOR 7, 0 DIM DATA19 AS STRING ' REGIMES.PRN DATA19 = "C:\PETE\THESIS\MODULES\REGIMES.PRN" DIM DATA21 AS STRING ' UNITNPV.PRN DATA21 = "C:\PETE\THESIS\MODULES\UNITNPV.PRN" DIM DATA22 AS STRING ' CANDIDAT.PRN DATA22 = "C:\PETE\THESIS\MODULES\CANDIDAT.PRN" DIM UNIT AS SINGLE ' UNIT NUMBER DIM PERIOD AS SINGLE ' PERIOD DIM NPV AS SINGLE ' NET PRESENT VALUE DIM BESTNPV AS SINGLE ' BEST NPV DIM BESTUNIT AS SINGLE ' BEST UNIT DIM BESTPERIOD AS SINGLE ' BEST PERIOD DIM BESTSYSTEM AS SINGLE ' BEST SYSTEM DIM HARVSYS(10) AS SINGLE ' HARVEST SYSTEM PER PERIOD DIM CC AS STRING BESTNPV = -99999999999# ' SET NPV VERY LOW OPEN DATA21 FOR INPUT AS #21 ' OPEN UNITNPV.PRN DO WHILE NOT EOF(21) ' WHILE NOT EOF UNITNPV.PRN INPUT #21, UNIT, PERIOD, SILV ' INPUT UNIT AND PERIOD FOR J = 0 TO 8 ' FOR EACH SYSTEM INPUT #21, NPV ' INPUT NPV IF NPV > BESTNPV THEN ' CHECK TO SEE WHICH UNIT- BESTNPV = NPV ' PERIOD-SYSTEM COMBINATION BESTPERIOD = PERIOD ' WOULD MAKE THE BEST CHOICE BESTUNIT = UNIT BESTSYSTEM = J BESTSILV = SILV END IF NEXT J ' NEXT SYSTEM LOOP CLOSE #21 ' VERIFIED 9/13/95 IF BESTNPV < -99999999998# THEN BESTUNIT = -1 H = BESTNPV Y = BESTPERIOD E = BESTUNIT F = BESTSILV G = BESTSYSTEM 'PRINT "BESTUNIT "; BESTUNIT 'PRINT "BESTPERIOD "; BESTPERIOD 'PRINT "BESTSYSTEM "; BESTSYSTEM 'PRINT "BEST SILV. "; BESTSILV 'PRINT "BEST NPV "; BESTNPV 'CC = INPUT$(1) OPEN DATA19 FOR INPUT AS #19 ' PRINTING A REGIME TO CANDIDAT.PRN DO WHILE NOT EOF(19) INPUT #19, UNIT, SILV, LOGG, HARVSYS(1), HARVSYS(2), HARVSYS(3), HARVSYS(4), HARVSYS(5), HARVSYS(6), HARVSYS(7), HARVSYS(8), HARVSYS(9), HARVSYS(10) IF UNIT = BESTUNIT AND SILV = BESTSILV AND LOGG = BESTSYSTEM THEN OPEN DATA22 FOR OUTPUT AS #22 PRINT #22, BESTUNIT; BESTSILV; HARVSYS(1); HARVSYS(2); HARVSYS(3); HARVSYS(4); HARVSYS(5); HARVSYS(6); HARVSYS(7); HARVSYS(8); HARVSYS(9); HARVSYS(10) CLOSE #22 GOTO SAVANAH END IF LOOP SAVANAH: CLOSE #19 PRINT USING " Period ## Candidate Unit ##### Logging System # Silv. Mgt. Regime #"; BESTPERIOD; BESTUNIT; BESTSYSTEM; BESTSILV REM ************************************************************ REM REM END - CHOOSING A UNIT TO ENTER THE SOLUTION AS A CANDIDATE REM REM ************************************************************ END SUB