C MEMBER FLAND1 C (from old member FCFLAND1) C SUBROUTINE FLAND1(PXV,EDMND,DT, + UZTWC,UZFWC,LZTWC,LZFSC,LZFPC,ADIMC, + UZTWM,UZFWM,UZK,PCTIM,ADIMP,RIVA,ZPERC,REXP,LZTWM,LZFSM, + LZFPM,LZSK,LZPK,PFREE,SIDE,SAVED,SURF,GRND,TET) cc &LZFPC,ADIMC,SPERC,ROIMP,SDRO,SSUR,SIF,BFS,BFP,TCI,EDMND,TET) cc SPERC,ROIMP,SDRO,SSUR,SIF,BFS,BFP,TCI,EDMND,TET) C....................................... C THIS SUBROUTINE EXECUTES THE 'SAC-SMA ' OPERATION FOR ONE TIME C PERIOD. C....................................... C SUBROUTINE INITIALLY WRITTEN BY. . . C ERIC ANDERSON - HRL APRIL 1979 VERSION 1 C Modifications to the routine were made by. . . c Bryce Finnerty - HRL July 1995 c Modifications include rearranging the common blocks and arguement c list so that the model can be run in stand-alone mode for the c Distributed Modeling Project. All state variables, water balance c components, and time information is passed through the arguement c list so that the routine can be called by a C driver program. C....................................... REAL LZTWM,LZFSM,LZFPM,LZSK,LZPK,LZTWC,LZFSC,LZFPC C C COMMON BLOCKS cc COMMON/FSMPM1/UZTWM,UZFWM,UZK,PCTIM,ADIMP,RIVA,ZPERC,REXP,LZTWM, cc 1LZFSM,LZFPM,LZSK,LZPK,PFREE,SIDE,SAVED,PAREA cc COMMON/FSUMS1/SROT,SIMPVT,SRODT,SROST,SINTFT,SGWFP,SGWFS,SRECHT, cc 1SETT,SE1,SE3,SE4,SE5,RSUM(7) Cc COMMON/PARMS/ETT(24),EPDIST(24),IDT,DT,KINT,EFC, cc &PEADJ,RSERV,PXADJ C....................................... CC write(*,*)' ' CC write(*,999) '1',UZTWC,UZFWC,LZTWC,LZFSC,LZFPC,ADIMC,PXV C C COMPUTED PARAMETERS FROM PINB1 SUBROUTINE PAREA=1.0-PCTIM-ADIMP C COMPUTE EVAPOTRANSPIRATION LOSS FOR THE TIME INTERVAL. C EDMND IS THE ET-DEMAND FOR THE TIME INTERVAL CCCC!! EDMND=EP*EPDIST(KINT) C C COMPUTE ET FROM UPPER ZONE. E1=EDMND*(UZTWC/UZTWM) RED=EDMND-E1 C RED IS RESIDUAL EVAP DEMAND UZTWC=UZTWC-E1 E2=0.0 IF(UZTWC.GE.0.) GO TO 220 C E1 CAN NOT EXCEED UZTWC E1=E1+UZTWC UZTWC=0.0 RED=EDMND-E1 IF(UZFWC.GE.RED) GO TO 221 C E2 IS EVAP FROM UZFWC. E2=UZFWC UZFWC=0.0 RED=RED-E2 GO TO 225 221 E2=RED UZFWC=UZFWC-E2 RED=0.0 220 IF((UZTWC/UZTWM).GE.(UZFWC/UZFWM)) GO TO 225 C UPPER ZONE FREE WATER RATIO EXCEEDS UPPER ZONE C TENSION WATER RATIO, THUS TRANSFER FREE WATER TO TENSION UZRAT=(UZTWC+UZFWC)/(UZTWM+UZFWM) UZTWC=UZTWM*UZRAT UZFWC=UZFWM*UZRAT 225 IF (UZTWC.LT.0.00001) UZTWC=0.0 IF (UZFWC.LT.0.00001) UZFWC=0.0 C C COMPUTE ET FROM THE LOWER ZONE. C COMPUTE ET FROM LZTWC (E3) E3=RED*(LZTWC/(UZTWM+LZTWM)) LZTWC=LZTWC-E3 IF(LZTWC.GE.0.0) GO TO 226 C E3 CAN NOT EXCEED LZTWC E3=E3+LZTWC LZTWC=0.0 226 RATLZT=LZTWC/LZTWM RATLZ=(LZTWC+LZFPC+LZFSC-SAVED)/(LZTWM+LZFPM+LZFSM-SAVED) IF(RATLZT.GE.RATLZ) GO TO 230 C RESUPPLY LOWER ZONE TENSION WATER FROM LOWER C ZONE FREE WATER IF MORE WATER AVAILABLE THERE. DEL=(RATLZ-RATLZT)*LZTWM C TRANSFER FROM LZFSC TO LZTWC. LZTWC=LZTWC+DEL LZFSC=LZFSC-DEL IF(LZFSC.GE.0.0) GO TO 230 C IF TRANSFER EXCEEDS LZFSC THEN REMAINDER COMES FROM LZFPC LZFPC=LZFPC+LZFSC LZFSC=0.0 230 IF (LZTWC.LT.0.00001) LZTWC=0.0 C C COMPUTE ET FROM ADIMP AREA.-E5 E5=E1+(RED+E2)*((ADIMC-E1-UZTWC)/(UZTWM+LZTWM)) C ADJUST ADIMC,ADDITIONAL IMPERVIOUS AREA STORAGE, FOR EVAPORATION. ADIMC=ADIMC-E5 IF(ADIMC.GE.0.0) GO TO 231 C E5 CAN NOT EXCEED ADIMC. E5=E5+ADIMC ADIMC=0.0 231 E5=E5*ADIMP C E5 IS ET FROM THE AREA ADIMP. C....................................... C COMPUTE PERCOLATION AND RUNOFF AMOUNTS. TWX=PXV+UZTWC-UZTWM C TWX IS THE TIME INTERVAL AVAILABLE MOISTURE IN EXCESS C OF UZTW REQUIREMENTS. IF(TWX.GE.0.0) GO TO 232 C ALL MOISTURE HELD IN UZTW--NO EXCESS. UZTWC=UZTWC+PXV TWX=0.0 GO TO 233 C MOISTURE AVAILABLE IN EXCESS OF UZTW STORAGE. 232 UZTWC=UZTWM 233 ADIMC=ADIMC+PXV-TWX C C COMPUTE IMPERVIOUS AREA RUNOFF. ROIMP=PXV*PCTIM C ROIMP IS RUNOFF FROM THE MINIMUM IMPERVIOUS AREA. cc SIMPVT=SIMPVT+ROIMP C C INITIALIZE TIME INTERVAL SUMS. SBF=0.0 SSUR=0.0 SIF=0.0 SPERC=0.0 SDRO=0.0 SPBF=0.0 C C DETERMINE COMPUTATIONAL TIME INCREMENTS FOR THE BASIC TIME C INTERVAL NINC=1.0+0.2*(UZFWC+TWX) C NINC=NUMBER OF TIME INCREMENTS THAT THE TIME INTERVAL C IS DIVIDED INTO FOR FURTHER C SOIL-MOISTURE ACCOUNTING. NO ONE INCREMENT C WILL EXCEED 5.0 MILLIMETERS OF UZFWC+PAV DINC=(1.0/NINC)*DT C DINC=LENGTH OF EACH INCREMENT IN DAYS. PINC=TWX/NINC C PINC=AMOUNT OF AVAILABLE MOISTURE FOR EACH INCREMENT. C COMPUTE FREE WATER DEPLETION FRACTIONS FOR C THE TIME INCREMENT BEING USED-BASIC DEPLETIONS C ARE FOR ONE DAY DUZ=1.0-((1.0-UZK)**DINC) DLZP=1.0-((1.0-LZPK)**DINC) DLZS=1.0-((1.0-LZSK)**DINC) C....................................... C START INCREMENTAL DO LOOP FOR THE TIME INTERVAL. C....................................... DO 240 I=1,NINC ADSUR=0.0 C COMPUTE DIRECT RUNOFF (FROM ADIMP AREA). RATIO=(ADIMC-UZTWC)/LZTWM IF (RATIO.LT.0.0) RATIO=0.0 ADDRO=PINC*(RATIO**2) C ADDRO IS THE AMOUNT OF DIRECT RUNOFF FROM THE AREA ADIMP. C C COMPUTE BASEFLOW AND KEEP TRACK OF TIME INTERVAL SUM. BF=LZFPC*DLZP LZFPC=LZFPC-BF IF (LZFPC.GT.0.0001) GO TO 234 BF=BF+LZFPC LZFPC=0.0 234 SBF=SBF+BF SPBF=SPBF+BF BF=LZFSC*DLZS LZFSC=LZFSC-BF IF(LZFSC.GT.0.0001) GO TO 235 BF=BF+LZFSC LZFSC=0.0 235 SBF=SBF+BF C C COMPUTE PERCOLATION-IF NO WATER AVAILABLE THEN SKIP IF((PINC+UZFWC).GT.0.01) GO TO 251 UZFWC=UZFWC+PINC GO TO 249 251 PERCM=LZFPM*DLZP+LZFSM*DLZS PERC=PERCM*(UZFWC/UZFWM) DEFR=1.0-((LZTWC+LZFPC+LZFSC)/(LZTWM+LZFPM+LZFSM)) C DEFR IS THE LOWER ZONE MOISTURE DEFICIENCY RATIO FR=1.0 C FR IS THE CHANGE IN PERCOLATION WITHDRAWAL DUE TO FROZEN GROUND. FI=1.0 C FI IS THE CHANGE IN INTERFLOW WITHDRAWAL DUE TO FROZEN GROUND. IFRZE=0 IF (IFRZE.EQ.0) GO TO 239 UZDEFR=1.0-((UZTWC+UZFWC)/(UZTWM+UZFWM)) CB CALL FGFR1(DEFR,FR,UZDEFR,FI) 239 PERC=PERC*(1.0+ZPERC*(DEFR**REXP))*FR C NOTE...PERCOLATION OCCURS FROM UZFWC BEFORE PAV IS ADDED. IF(PERC.LT.UZFWC) GO TO 241 C PERCOLATION RATE EXCEEDS UZFWC. PERC=UZFWC C PERCOLATION RATE IS LESS THAN UZFWC. 241 UZFWC=UZFWC-PERC C CHECK TO SEE IF PERCOLATION EXCEEDS LOWER ZONE DEFICIENCY. CHECK=LZTWC+LZFPC+LZFSC+PERC-LZTWM-LZFPM-LZFSM IF(CHECK.LE.0.0) GO TO 242 PERC=PERC-CHECK UZFWC=UZFWC+CHECK 242 SPERC=SPERC+PERC C SPERC IS THE TIME INTERVAL SUMMATION OF PERC C C COMPUTE INTERFLOW AND KEEP TRACK OF TIME INTERVAL SUM. C NOTE...PINC HAS NOT YET BEEN ADDED DEL=UZFWC*DUZ*FI SIF=SIF+DEL UZFWC=UZFWC-DEL C DISTRIBE PERCOLATED WATER INTO THE LOWER ZONES C TENSION WATER MUST BE FILLED FIRST EXCEPT FOR THE PFREE AREA. C PERCT IS PERCOLATION TO TENSION WATER AND PERCF IS PERCOLATION C GOING TO FREE WATER. PERCT=PERC*(1.0-PFREE) IF ((PERCT+LZTWC).GT.LZTWM) GO TO 243 LZTWC=LZTWC+PERCT PERCF=0.0 GO TO 244 243 PERCF=PERCT+LZTWC-LZTWM LZTWC=LZTWM C C DISTRIBUTE PERCOLATION IN EXCESS OF TENSION C REQUIREMENTS AMONG THE FREE WATER STORAGES. 244 PERCF=PERCF+PERC*PFREE IF(PERCF.EQ.0.0) GO TO 245 HPL=LZFPM/(LZFPM+LZFSM) C HPL IS THE RELATIVE SIZE OF THE PRIMARY STORAGE C AS COMPARED WITH TOTAL LOWER ZONE FREE WATER STORAGE. RATLP=LZFPC/LZFPM RATLS=LZFSC/LZFSM C RATLP AND RATLS ARE CONTENT TO CAPACITY RATIOS, OR C IN OTHER WORDS, THE RELATIVE FULLNESS OF EACH STORAGE FRACP=(HPL*2.0*(1.0-RATLP))/((1.0-RATLP)+(1.0-RATLS)) C FRACP IS THE FRACTION GOING TO PRIMARY. IF (FRACP.GT.1.0) FRACP=1.0 PERCP=PERCF*FRACP PERCS=PERCF-PERCP C PERCP AND PERCS ARE THE AMOUNT OF THE EXCESS C PERCOLATION GOING TO PRIMARY AND SUPPLEMENTAL C STORGES,RESPECTIVELY. LZFSC=LZFSC+PERCS IF(LZFSC.LE.LZFSM) GO TO 246 PERCS=PERCS-LZFSC+LZFSM LZFSC=LZFSM 246 LZFPC=LZFPC+(PERCF-PERCS) C CHECK TO MAKE SURE LZFPC DOES NOT EXCEED LZFPM. IF (LZFPC.LE.LZFPM) GO TO 245 EXCESS=LZFPC-LZFPM LZTWC=LZTWC+EXCESS LZFPC=LZFPM C C DISTRIBUTE PINC BETWEEN UZFWC AND SURFACE RUNOFF. 245 IF(PINC.EQ.0.0) GO TO 249 C CHECK IF PINC EXCEEDS UZFWM IF((PINC+UZFWC).GT.UZFWM) GO TO 248 C NO SURFACE RUNOFF UZFWC=UZFWC+PINC GO TO 249 C C COMPUTE SURFACE RUNOFF (SUR) AND KEEP TRACK OF TIME INTERVAL SUM. 248 SUR=PINC+UZFWC-UZFWM UZFWC=UZFWM SSUR=SSUR+SUR*PAREA ADSUR=SUR*(1.0-ADDRO/PINC) C ADSUR IS THE AMOUNT OF SURFACE RUNOFF WHICH COMES C FROM THAT PORTION OF ADIMP WHICH IS NOT C CURRENTLY GENERATING DIRECT RUNOFF. ADDRO/PINC C IS THE FRACTION OF ADIMP CURRENTLY GENERATING C DIRECT RUNOFF. SSUR=SSUR+ADSUR*ADIMP C C ADIMP AREA WATER BALANCE -- SDRO IS THE IDT SUM OF C DIRECT RUNOFF. 249 ADIMC=ADIMC+PINC-ADDRO-ADSUR IF (ADIMC.LE.(UZTWM+LZTWM)) GO TO 247 ADDRO=ADDRO+ADIMC-(UZTWM+LZTWM) ADIMC=UZTWM+LZTWM 247 SDRO=SDRO+ADDRO*ADIMP IF (ADIMC.LT.0.00001) ADIMC=0.0 240 CONTINUE C....................................... C END OF INCREMENTAL DO LOOP. C....................................... C COMPUTE SUMS AND ADJUST RUNOFF AMOUNTS BY THE AREA OVER C WHICH THEY ARE GENERATED. EUSED=E1+E2+E3 C EUSED IS THE ET FROM PAREA WHICH IS 1.0-ADIMP-PCTIM SIF=SIF*PAREA C C SEPARATE CHANNEL COMPONENT OF BASEFLOW C FROM THE NON-CHANNEL COMPONENT TBF=SBF*PAREA C TBF IS TOTAL BASEFLOW BFCC=TBF*(1.0/(1.0+SIDE)) C BFCC IS BASEFLOW, CHANNEL COMPONENT BFP=SPBF*PAREA/(1.0+SIDE) BFS=BFCC-BFP IF(BFS.LT.0.0) BFS=0.0 BFNCC=TBF-BFCC C BFNCC IS BASEFLOW,NON-CHANNEL COMPONENT C C ADD TO MONTHLY SUMS. cc SINTFT=SINTFT+SIF cc SGWFP=SGWFP+BFP cc SGWFS=SGWFS+BFS cc SRECHT=SRECHT+BFNCC cc SROST=SROST+SSUR cc SRODT=SRODT+SDRO C C COMPUTE TOTAL CHANNEL INFLOW FOR THE TIME INTERVAL. TCI=ROIMP+SDRO+SSUR+SIF+BFCC GRND = SIF + BFCC ! interflow is part of ground flow CC GRND = BFCC ! interflow is part of surface flow SURF = TCI - GRND C C COMPUTE E4-ET FROM RIPARIAN VEGETATION. E4=(EDMND-EUSED)*RIVA C C SUBTRACT E4 FROM CHANNEL INFLOW TCI=TCI-E4 IF(TCI.GE.0.0) GO TO 250 E4=E4+TCI TCI=0.0 cc 250 SROT=SROT+TCI 250 CONTINUE GRND = GRND - E4 IF (GRND .LT. 0.) THEN SURF = SURF + GRND GRND = 0. IF (SURF .LT. 0.) SURF = 0. END IF C C COMPUTE TOTAL EVAPOTRANSPIRATION-TET EUSED=EUSED*PAREA TET=EUSED+E5+E4 cc SETT=SETT+TET cc SE1=SE1+E1*PAREA cc SE3=SE3+E3*PAREA cc SE4=SE4+E4 cc SE5=SE5+E5 C CHECK THAT ADIMC.GE.UZTWC IF (ADIMC .LT. UZTWC) ADIMC=UZTWC C C COMPUTE NEW FROST INDEX AND MOISTURE TRANSFER. c IF (IFRZE.GT.0) THEN C CALL FROST1(PXV,SSUR,SDRO,TA,LWE,WE,ISC,AESC,DT, C 1 IBUG) c END IF C....................................... C PRINT DETAILED ACCOUNTING VALUES IF REQUESTED. c WRITE (66,905) IDAY,IHOUR,UZTWC,UZFWC, c 1LZTWC,LZFSC,LZFPC,ADIMC,SPERC,ROIMP,SDRO,SSUR,SIF,BFS,BFP,TCI, c 2EDMND,TET,PXV c 905 FORMAT (/,2I3,F7.2,F7.3,F7.2,F7.3,2F7.2,7F7.3,2F8.3,F7.3, c &F9.2) C C....................................... c WRITE(66,667) CC write(*,999) '2',UZTWC,UZFWC,LZTWC,LZFSC,LZFPC,ADIMC,PXV CC write(*,888)UZTWC,UZFWC,LZTWC, CC + LZFSC,LZFPC,ADIMC, PXV,EDMND, SURF,GRND,TET 667 FORMAT(/,'** FLAND1 EXITED **') 888 FORMAT(6F7.2, 5f7.3) 999 FORMAT(a,7F7.2) RETURN END