c file: crop.for c Author : Amare Retta subroutine crop (bnslay, bszlyt, bszlyd, bsdblk, bsfcce, bsfom, * bsfcec, bsfsmb, bsfcla, bs0ph, & bsftan, bsftap, & bczrtd, bcmrtz, bsmno3, bc0bn1, bc0bn2, bc0bn3, & bc0bp1, bc0bp2, bc0bp3, bc0ck, bcrhi, bcehu0, * bczmxc, bc0idc, bctdtm, & bczmrt, bctmin, bctopt, & bc0fd1, bc0fd2, cc0fd1, cc0fd2, & bc0be1, bc0be2, cc0be1, cc0be2, & bdmb,bc0alf,bc0blf,bc0clf,bc0dlf,bc0arp, * bc0brp,bc0crp,bc0drp, & bc0aht, bc0bht, bc0ssa, bc0ssb, bc0sla, * bc0hue, bc0lfe, * bweirr,bwtdav,bwtdmn,bwzdpt, * bhzpta, bhzeta, bhzptp, bhfwsf, * bm0cif, bm0hrvfl, bm0cdb, bm0drmfl) c + + + PURPOSE + + + c This is the main program for implementing the crop growth c calculations in the various subroutines. For any questions refer c to Amare Retta at the USDA Wind Erosion Research Laboratory, c University, Manhattan KS 66506. c c + + + KEYWORDS + + + c Wind erosion crop model c + + + ARGUMENT DECLARATIONS + + + integer bc0idc, bnslay, bctdtm, bm0hrvfl real bszlyt(*), * bszlyd(*), bsdblk(*), bsfcec(*), bsfcce(*), * bsfom(*), bsfcla(*), bs0ph(*), r bsftan(*), bsftap(*), r bsfsmb(*), bczrtd, bcmrtz(*), bsmno3, r bc0bn1, bc0bn2, bc0bn3, r bc0bp1, bc0bp2, bc0bp3, bc0ck, bcrhi, bcehu0, bczmxc, r bczmrt, bctmin, bctopt, r bc0fd1, bc0fd2, r cc0fd1, cc0fd2, bc0be1, bc0be2, cc0be1, cc0be2, bdmb(*), r bc0alf, bc0blf, bc0clf, bc0dlf, bc0arp, bc0brp, * bc0crp, bc0drp, bc0aht, bc0bht, r bc0ssa, bc0ssb, bc0sla, bc0hue, bc0lfe, * bweirr, bwtdav, bwtdmn, bwzdpt, * bhzpta, bhzeta, bhzptp, bhfwsf logical bm0cif integer bm0cdb, bm0drmfl c + + + ARGUMENT DEFINITIONS + + + c bc0alf - leaf partitioning parameter c bc0arp - rprd partitioning parameter c bc0aht - height s-curve parameter c bsmno3 - amount of applied N (t/ha) c bc0blf - leaf partitioning parameter c bc0brp - rprd partitioning parameter c bc0bht - height s-curve parameter c bsdblk - bulk density of a layer (g/cm^3=t/m^3) c bdmb - residue amount by soil layer c bc0bn1 - normal fraction of N in crop biomass at emergence c bc0bn2 - normal fraction of N in crop biomass at midseasn c bc0bn3 - normal fraction of N in crop biomass at maturity c bc0bp1 - normal fraction of P in crop biomass at emergence c bc0bp2 - normal fraction of P in crop biomass at midseasn c bc0bp3 - normal fraction of P in crop biomass at maturity c bsfcce - calcium carbonate (%) c bsfcla - % clay c bsfom - percent organic matter c bsftan - total available N in a layer from all sources (kg/ha) c bsftap - total available P in a layer from all sources (kg/ha) c bc0clf - leaf partitioning parameter c bc0crp - rprd partitioning parameter c bsfcec - cation exchange capacity (cmol/kg) c bc0ck - extinction coeffficient (fraction) c bc0lfe - leaf area at emergence (cm^2/plant) c bc0dlf - leaf partitioning parameter c bc0drp - rprd partitioning parameter c dmag - stress adjusted cummulated aboveground biomass (t/ha) c bctdtm - days to maturity (same as dtm) c bc0fd1 - minimum temperature below zero (C) c cc0fd1 - fraction of biomass lost each day due to frost c bc0fd2 - minimum temperature below zero (C) c cc0fd2 - fraction of biomass lost each day due to frost c bcrhi - yield index of a crop (ratio) c bczmxc - maximum potential plant height (m) c bc0hue - relative heat unit for emergence (fraction) c bc0idc - crop type:annual,perennial,etc c bnslay - number of soil layers c bs0ph - soil pH c phu - potential heat units for crop maturity (deg. C) c bczrtd - root depth (m) c bcmrtz - root biomass (by depth) c bczmrt - maximum root depth c bc0sla - specific leaf area (cm^2/g) c bsfsmb - sum of bases (cmol/kg) c bc0ssa - parameter of the specific stem area function (cm^2/g) c bc0ssb - parameter of the specific stem area function (cm^2/g) c bctmin - base temperature (deg. C) c bctopt - optimum temperature (deg. C) c bc0be1 - CO2 concentration(ppm) c cc0be1 - biomass conversion efficiency (kg/ha/mj) c bc0be2 - CO2 concentration(ppm) c cc0be2 - biomass conversion efficiency (kg/ha/mj) c bszlyd - depth from top of soil to botom of layer, m c + + + GLOBAL COMMON BLOCKS + + + *$noreference include 'p1werm.inc' include 'm1dbug.inc' C *** include 'm1sim.inc' include 'c1gen.inc' c + + + COMMON BLOCKS + + + include 'crop/cgrow.inc' include 'crop/cenvr.inc' include 'crop/cparm.inc' include 'crop/csoil.inc' include 'crop/chumus.inc' include 'crop/cfert.inc' include 'manage/oper.inc' *$reference c + + + LOCAL VARIABLES + + + integer l, dd, mm, yy c + + + LOCAL VARIABLE DEFINITIONS + + + c dd,mm,yy - the current day, month, and year c c + + + SUBROUTINES CALLED + + + c caldat c cinit c huc1 c growth c npcy c c + + + FUNCTION DECLARATIONS + + + integer dayear c c + + + OUTPUT FORMATS + + + c2012 format(1x,8(f6.2,1x)) 2013 format(1x,i4,1x,10(f6.1,1x),1x,f6.3) c + + + END OF SPECIFICATIONS + + + dtm=bctdtm C *** write(*,*) ' crop: bhzpta ', bhzpta do 5 l = 1, bnslay bsfcce(l) = bsfcce(l) * 100. bsfom(l) = bsfom(l) * 100. bsfcla(l) = bsfcla(l) * 100. wn(l) = 0.0 wp(l) = 0.0 wno3(l) = bsftan(l) ap(l) = bsftap(l) c residue is now passed from MAIN and converted here from kg/m^2 to t/ha c residue was previously estimated in subroutine sdst c the validity of this needs to be checked since type of residue (rsd) c needed is not clearin CROP - jt 07/21/94 c I think this (rsd) is being used in the nutrient cycling. c Thus, it probably should be the sum of admbgz and admrtz c (all pools) for each layer. LEW 4/23/99 rsd(l) = bdmb(l) * 10.0 5 continue c initialize growth and nutrient variables c initialize on first day of simulation and after each planting c bm0cif is flag to initialize crop at tart of planting if (bm0cif) then call cinit (bnslay, bszlyt, bszlyd, bsdblk, bsfcce, bsfcec, * bsfsmb, bsfom, bsfcla, bs0ph, & bc0bn1, bc0bn2, bc0bn3, bc0bp1, bc0bp2, * bc0bp3, bsmno3, & bc0fd1, bc0fd2,bctmin, & cc0fd1, cc0fd2, bc0be1, bc0be2, cc0be1, * cc0be2, & bc0sla,bc0lfe,bc0idc) bm0cif = .false. !turn off after initialization is complete endif c C *** ra = bweirr C *** tmx = bwtdmx C *** tmn = bwtdmn C *** r = bwzdpt c day of year call caldat(-1, dd, mm, yy) jd = dayear(dd, mm, yy) c calculate growing degree days if (shu .gt. phu) goto 999 bm0drmfl=0 call huc1 (bctmin, bwtdav) c calculate cummulative transpiration & evapotranspiration if (shu.le.phu) then cta=cta+bhzpta ceta=ceta+bhzeta prcp=prcp+bwzdpt ctp=ctp+bhzptp endif 999 continue c print end of season values: moved to this location: 10/1/99 if(hui.ge.1.) iprint=iprint+1 if (iprint.eq.1)write(59,2013)yy,clfwt,cstwt,crpwt,yld,dmag, & cta,ceta,prcp,ctp,slaix,ssaix if (hui.lt.1.) iprint=0 c calculate plant growth state variables call growth (bnslay, bszlyd, bczrtd, bcmrtz, bc0ck, bcrhi, * bcehu0, bczmxc, bc0idc, & bczmrt, bctmin, bctopt,bc0be1, & bc0alf,bc0blf,bc0clf,bc0dlf,bc0arp, * bc0brp,bc0crp,bc0drp, & bc0aht,bc0bht,bc0ssa,bc0ssb,bc0sla,bc0hue, * bwtdav, bwtdmn, bweirr, bhfwsf) c print masses after a killing or non-killing harvest for perennials if (bc0idc.eq.3 .or. bc0idc .eq. 6) then if (bm0hrvfl.gt.0)call cprnl(bczmxc,dd,mm,yy) if (jd.ge.365)call cprnl(bczmxc,dd,mm,yy) endif c print end-of-season values for annuals : now done above 10/18/99 C *** write(*,*) ' crop ', bm0cdb, bc0idc, bm0hrvfl c following 6 lines commented out : 10/18/99 c if (bm0cdb.eq.2) then c if (bc0idc.eq.1.or.bc0idc.eq.2.or.bc0idc.eq.4.or.bc0idc.eq.5) then c if(bm0hrvfl.eq.2) write(59,2013)yy,clfwt,cstwt,crpwt,yld,dmag, c & cta,ceta,prcp,ctp,slaix,ssaix c endif c endif do 555 l = 1, bnslay bsfcce(l) = bsfcce(l) / 100. bsfom(l) = bsfom(l) / 100. bsfcla(l) = bsfcla(l) / 100. 555 continue c write (*,759) c 759 format (' getting out of crop') return end