subroutine frcfac(nowcrp) c c + + + PURPOSE + + + c Computes the soil grain friction factor (frcsol(iplane)), the total c rill friction factor (frctrl(iplane)), and the equivalent weighting c friction factor for rills (frcteq(iplane)). c c Generates the interrill and rill friction factors for the c erosion component; computes the time-variant roughness c coefficients for overland flow routing. c c Called from IRS. c Author(s): c Reference in User Guide: c c Changes: c 1) Common blocks: CLIYR, CRPVR1, & CRPVR5 were not accessed. c Reference to them was deleted. c 2) Since INRCOV & RILCOV are just read in INPUT, used c in this routine, and not used anywhere else, they c are no longer set to zero, if their original values c are negative. c 3) RROUGH is handled in a similar fashion, for the same c reason. c 4) Calculations for RILARE(MXPLAN) simplified, and c RILARE(MXPLAN) changed to local variable RILLAR. c ****************************************************************** c * NOTE: "RILARE" SHOULD BE REMOVED FROM COMMON BLOCK "FFACT". * c ****************************************************************** c 5) SAVE statement, which saves ALL local variables, removed. c 6) Removed use of variables FRSPRV and FRTPRV because c variables FRCSOL and FRCTRL have now been dimensioned c to MXPLAN, and we can use the previous plane's value of c these in SR PARAM directly. Also removed them from c common /ffact/. Computation of FRSPRV and FRTPRV in c WEPP version 93.2 was in error. dcf 10/14/93 c c c Version: This module recoded from WEPP version 91.10. c Date recoded: 04/22/91 - 4/23/91. c Recoded by: Charles R. Meyer. c c + + + KEYWORDS + + + c c + + + ARGUMENT DECLARATIONS + + + integer nowcrp c c + + + ARGUMENT DEFINITIONS + + + c c + + + PARAMETERS + + + include 'pntype.inc' include 'pmxnsl.inc' include 'ptilty.inc' include 'pmxpln.inc' include 'pmxcrp.inc' include 'pmxelm.inc' include 'pmxres.inc' include 'pmxtls.inc' include 'pmxtil.inc' include 'pmxhil.inc' include 'pmxgrz.inc' c c + + + COMMON BLOCKS + + + include 'cffact.inc' c modify: frcsol(iplane), frctrl(iplane) c write: frcteq(iplane) c include 'ccontcv.inc' c read: tilseq(mxcrop,mxplan) c include 'ccrpvr2.inc' c read: ar(ntype),flivmx(nowcrp(iplane)) c include 'ccrpvr3.inc' c read: hmax(ntype) c include 'ccover.inc' c read: lanuse(mxplan), canhgt(mxplan), inrcov(mxplan), c rilcov(mxplan) c include 'ccrpout.inc' c read: rescov(mxplan), rrc(mxplan) c include 'ccrpprm.inc' c read: itype, itill c include 'cends.inc' c read: rspace(mxplan), width(mxplan) c include 'cfripas.inc' c include 'crinpt1.inc' c read: wcf(mxplan) c c include 'crinpt1a.inc' c include 'crinpt6.inc' c read: rufcov(mxplan), rrough(mxplan) c include 'cslinit.inc' c read: rrinit(mxplan) c include 'csolvar.inc' c read: sand, clay c include 'cstruc.inc' c read: iplane c include 'ctillge.inc' c read: rro c include 'cupdate.inc' c read: indxy(mxplan) c c + + + LOCAL VARIABLES + + + c real inrfso, inrfo, inrrou, inrfro, inrfco, inrfto, rroinr, c 1 rrrinr, frrraf, frrrok, frirok, rillar, frires real inrfso, inrfo, inrrou, inrfco, rroinr, rrrinr integer i1, i2, idplnt c c + + + LOCAL DEFINITIONS + + + c inrfso - friction due to soil texture c inrfo - Darcy friction coefficient for interrill surface c inrrou - c inrfro - friction due to form roughness c inrfco - Darcy friction coefficient for interrill surface c area c inrfto - total Darcy friction factor for the interrill area c rroinr - initial random roughness of a freshly tilled c surface c rrrinr - c frccov(iplane) - Darcy friction coefficient for rill surface cover c frican(iplane) - friction due to canopy cover c flivmx - c frlive(iplane) - c frrraf - friction due to form roughness c frrrok - friction (rill) due to rock and gravel c frirok - friction (interrill) due to rock and gravel c frrres(iplane) - friction (rill) due to residue c frires(iplane) - friction (interrill) due to residue c fribas(iplane) - friction due to basal cover and cryptogram c fritot - sum of fribas(iplane) and frican under rangeland c rillar - rill area c i1 - c i2 - c idplnt - c c + + + END SPECIFICATIONS + + + c c *** L0 IF *** if (lanuse(iplane).eq.1) then c c hydraulic roughness for interrill areas c inrfro = 0.0 c c friction coefficient for smooth bare soil on an c interrill area c inrfso = 4.07 c i1 = indxy(iplane) i2 = tilseq(nowcrp,iplane) if (i2.gt.0) then if (indxy(iplane).eq.0)then rroinr = rrinit(iplane) elseif(resman(i1,i2).eq.10 .or. resman(i1,i2).eq.11) then rroinr = rrinit(iplane) else rroinr = rro(i1,i2) end if rrrinr = rrc(iplane) / rroinr if (rrrinr.gt.1.0) rrrinr = 1.0 inrfo = exp(3.024-5.042*exp(-161.*rroinr)) c c friction coefficient for interrill surface roughness c inrrou = 0.5 * (inrfo**1.128) * exp(-3.088*(1.0-rrrinr)) if (inrrou.lt.inrfso) inrrou = inrfso inrfro = inrrou - inrfso end if c if (inrcov(iplane).gt.0.0) then c c friction coefficient for interrill surface cover c inrfco = 14.5 * (inrcov(iplane)) ** 1.5544 else inrcov(iplane) = 0.0 inrfco = 0.0 end if c c New section added 5/16/90 by dcf to account for roughness c introduced by living grasses, small grains, and alfalfa c idplnt = itype(nowcrp,iplane) c if (hmax(idplnt).gt.0.0) then frlive(iplane) = (canhgt(iplane)/hmax(idplnt)) * 1 flivmx(idplnt) else frlive(iplane) = 0.0 end if c c total friction factor for interrill area c inrfto = inrfro + inrfco + inrfso + frlive(iplane) c c hydraulic roughness for rills c frcsol(iplane) = 1.11 c c Gilley's new equation - 5/16/90 c Changed by Nearing - 12/94 c if (rilcov(iplane).gt.0.0) then frccov(iplane) = 4.5 * (rilcov(iplane)) ** 1.5544 else rilcov(iplane) = 0.0 frccov(iplane) = 0.0 end if c c------- total rill friction frctrl(iplane) = frccov(iplane) + frlive(iplane) + 1 frcsol(iplane) c c c *** L0 ELSEIF *** else if (lanuse(iplane).eq.2) then c c-------rill friction calculations c-------friction due to soil texture c c frcsol(iplane)=(3.42**clay(1,iplane)/12.42**sand(1,iplane))**0.5 c c Use Gilley's value for bare soil frcsol(iplane) instead of present c range equation. c frcsol(iplane) = 1.11 if (rrough(iplane).gt.0.006) then frrraf = 42.76 * (1.0-exp(-77.3*rrough(iplane))) else frrraf = 42.76 * (1.0-exp(-77.3*0.006)) end if c c Changes from Mary Kidwell/Mark Weltz follow: c frrrok = 1.8467 * wcf(iplane) c frrres(iplane) = 113.73 * rescov(iplane) ** 3.0 c frrrok = 1.8467 * frokr(iplane) * rokcov(iplane) frrres(iplane) = 113.73 * (fresr(iplane)*rescov(iplane)) ** 3.0 frrbas = 125.91 * (fbasr(iplane)*bascov(iplane) 1 + fcryr(iplane)*crycov(iplane)) ** 0.8 frrbas = frrbas/2.0 c frccov(iplane) = frrres(iplane) + frrrok + frrraf frccov(iplane) = frrrok + frrres(iplane) + frrbas + frrraf c c-------total rill friction c frctrl(iplane) = (frcsol(iplane)+frrraf+frrrok+frrres(iplane)- c 1 15.868) c frctrl(iplane) = (frcsol(iplane)+frrraf+frrrok+frrres(iplane)+ 1 frrbas - 15.868) if (frctrl(iplane).lt.frcsol(iplane)) frctrl(iplane) = 1 frcsol(iplane) c c-------interrill friction calculations c c inrfso=(3.42**clay(1,iplane)/12.42**sand(1,iplane))**0.5 c c Use Gilley's value for bare soil inrfso instead of present c range equation. c inrfso = 4.07 c if (rrough(iplane).gt.0.006) then inrfro = 42.76 * (1.0-exp(-77.3*rrough(iplane))) else inrfro = 42.76 * (1.0-exp(-77.3*0.006)) end if c c XXX Changes from Mary Kidwell and Mark Weltz 3/9/95 c frirok = 1.8467 * wcf(iplane) c frires = 113.73 * rescov(iplane) ** 3.0 c fribas(iplane) = 125.91 * rufcov(iplane) ** 0.8 frirok = 1.8467 * froki(iplane)*rokcov(iplane) frires = 113.73 * (fresi(iplane)*rescov(iplane)) ** 3.0 fribas(iplane) = 125.91 * (fbasi(iplane)*bascov(iplane) + 1 fcryi(iplane)*crycov(iplane)) ** 0.8 frican(iplane) = 38.95 * cancov(iplane) ** 0.8 inrfco = fribas(iplane) + frires + frirok + frican(iplane) inrfto = (inrfso+inrfro+frirok+frires+fribas(iplane)+ 1 frican(iplane)-15.868) / 0.64924 if (inrfto.lt.inrfso) inrfto = inrfso c c *** L0 ENDIF *** end if c c------compute rill area (RILLAR): rillar = width(iplane) / rspace(iplane) c c c Add the following IF/ELSE so that for the special case where c the user has specified that the rill width is equal to the c rill spacing (broad sheet flow assumption), then the model will c use the interrill friction factors only. dcf 8/22/94 c if(rillar .lt. 1.0) then c equivalent total fric factor for composite area frcteq(iplane) = inrfto + rillar * (frctrl(iplane)-inrfto) else frctrl(iplane) = inrfto frcsol(iplane) = inrfso frcteq(iplane) = inrfto endif c return end