c c subroutine remove i (sr,grainp,cropp,decompp,cutht,bgp, i dstand,dflat,droot,dblwgnd, i stand,roott,yield,nlay, i cropht,rootdt,dstemht, i cropname,croppop,flag) c + + + PURPOSE + + + c c This subroutine performs the biomass manipulation of removing c biomass. Removal can be from one or more of the following c processes: harvest, graze, burns and in the harvest process c the following can be removed: grain, crop, or all. The component c removed is determined by flag which is set before the call to c this subroutine. The flag may contain any number of combinations c found below. c c Flags (binary #'s actually) c 0 - remove standing crop at harvest height (1) c 1 - remove root mass of crop (2) c 2 - remove yield from a standing crop (4) c 3 - remove all standing mass (crop and decomp pools) at a c harvest height (16) c 4 - remove all above ground biomass (flat and standing) (32) c 5 - remove flat residue only (64) c 6 - remove nothing just put current crop into residue pools (128) c 7 - kill rootmass and transfer mass into decomp pool1 (256) c c + + + KEYWORDS + + + c remove, biomass manipulation *$noereference include 'p1werm.inc' include 's1layr.inc' include 'manage/harv.inc' *$reference c c + + + ARGUMENT DECLARATIONS + + + c real grainp,cropp,decompp,cutht,bgp real dstand(mnbpls),dflat(mnbpls),droot(mnbpls,mnsz), & dblwgnd(mnbpls,mnsz) real stand,roott,yield,dstemht(mnbpls) real cropht,rootdt,croppop c c + + + ARGUMENT DEFINITIONS + + + c c bqp - percent of below ground biomass crop c cropht - current crop height (m) c cropp - percent of crop removed (rest is left as flat residue) c croppop - crop population (number of stems) c cutht - the above ground height that a crop is cut to c a (-1) indicates the crop is below ground c dblwgnd - (decomp) below ground biomass by layer and pool (kg / m^2) c decomp - percent of decoposition material removed c dflat - (decomp) surface biomass by age pool (kg / m^2) c droot - (decomp) root biomass by layer and pool (kg / m^2) c dstand - (decomp) standing biomass by age pool (kg / m^2) c dstemht - (decomp) biomass stem height by pool (m) c flag - flag indicating which type of remove to perform c grainp - percent of grain removed c roott - crop root biomass (kg / m^2) NOT!! by layer c rootdt - crop root depth (m) c stand - standing crop biomass (kg / m^2) c yield - crop yield (kg / m^2) c c + + + ACCESSED COMMON BLOCK VARIABLE DEFINITIONS + + + c c mnbpls - max number of decomposition pools (currently=3) c mnsz - max number of soil layers c nslay - number of soil layers used in a subregion c c + + + PARAMETERS + + + c c + + + LOCAL VARIABLES + + + c character cropname*80 integer sr,i,j,k,lay,nlay,rtlay,rootlay,flag real s,ss,ad,bd,dd,ratio(mnsz) real flatmass,standmass,bgmass(mnsz),rtmass(mnsz) c c + + + LOCAL VARIABLE DEFINITIONS + + + c c ad - begining limit of integration for the triangular root distribution (mm) c bd - endind limit of integration for the triangular root distribution (mm) c bgmass - temporary below ground mass / layer (kg / m^2) c dd - root depth for all layers summed (mm) c flatmass - temporary flatmass pool (kg / m^2) c i - loop variable for decomp pools (3 pools total) c j - loop variable for # of integration steps in trapzd.for c k - loop variable for # of layers containing root mass c lay - number of layers in a specified subregion c nlay - number of layers in the tillage zone c ratio - ratio of total area roots are in to area in a layer c containing roots. Should always be < 1.0 and sum of c ratios should add up to 1.0. Used to determing root c in individual layers. c rtlay - number of layers containing root mass c rtmass - temporary rootmass pool / layer (kg / m^2) c s - returned value for the integrated function used c to determine root mass distribution. s containes c the integral for the entire root depht c (or more accuratly all layers containing roots) c ss - returned value for the integrated function used c to determine root mass distribution. ss containes c the integration over over a single layer. c standmass - temporary standing mass pool (kg / m^2) c all temporary pools are used when the call to kill (dechrv.for) is c made. The variables get stuck in the first biomass pool. c + + + END SPECIFICATIONS + + + c initialize harvmass to zero before removing biomass. harvmass = 0.0 c c****************************************************************** if (btest(flag,0) ) then c print *, 'Flag 0 is on' c print *, 'Remove standing crop at the harvest height' c Calculate the standing mass that is removed and determine which c pecentage of the mass goes to flat and which is removed totaly c Update the standing and flat mass pools accordingly. Note that c the yield is included in this standing mass. Maybe we should be c seperating this out before these calculations are made???? if (cutht.lt.cropht) then flatmass = flatmass+(1.0-cropp)*(stand-yield)* & (1.0-(cutht/cropht)) standmass = (stand-yield)*(cutht/cropht) harvmass = harvmass+(stand-yield)*(1.0-cutht/cropht) cropht = cutht else c print *, 'Nothing to remove/cut' endif endif c***************************************************************** if (BTEST(flag,1)) then c print *, 'Flag 1 is on' c print *, 'Remove root mass at the harvest depth' if (nlay.eq.0) then c print *, 'your depth is not deep enough to remove anything' c print *, 'make sure you entered a negitive cut height ' goto 201 endif do 200 lay=1,nlay rtmass(lay) = roott/nlay*(1.0 - bgp) c also need to remove roots from decomp pools(1 & 2) do 200 i=1,mnbpls droot(i,lay) = (1.0-bgp)*droot(i,lay) 200 continue endif 201 continue c***************************************************************** if (BTEST(flag,2)) then c print *, 'Flag 2 is on' c print *, 'Remove yield mass from the crop' c Remove the yield from the crop. Most of the yield will be removed c but some may go into the flat pool so we need to update this flatmass = flatmass+yield*(1.0-grainp) harvmass = harvmass+yield endif c**************************************************************** if (BTEST(flag,3)) then c print *, 'Flag 3 is on' c print *, 'Remove all standing mass at the harvest height' c This flag is set when there is a need to remove the c crop at a certain harvest height and other biomass not related c to the crop (ie. stuff in the decomp pools above the harvest c height) c print *, 'cropht', cropht c print *, 'cutht', cutht if (cutht.lt.cropht) then flatmass = flatmass+(1.0-cropp)* & (stand-yield)*(1.0-(cutht/cropht)) standmass = (stand-yield)*(cutht/cropht) harvmass = harvmass+(stand-yield)*(1.0-cutht/cropht) cropht = cutht else c print *, 'Nothing to remove/cut' endif do 40 i=1,mnbpls if (cutht.lt.dstemht(i)) then dflat(i) = dflat(i)+(1.0-decompp)*dstand(i)* & (1.0-cutht/dstemht(i)) dstand(i) = dstand(i)*(cutht/dstemht(i)) dstemht(i) = cutht if (dflat(i).lt.0.0) dflat(i)=0.0 if (dstand(i).lt.0.0) dstand(i)=0.0 if (dstemht(i).lt.0.0) dstemht(i)=0.0 else c print *, 'Nothing to remove/cut in decomp pool',i c pause endif 40 continue endif c**************************************************************** if (BTEST(flag,4)) then c print *, 'Flag 4 is on' c print *, 'Remove all above ground biomass (flat and standing)' c Remove all biomass flat and standing(100%). This includes both the c current crop and the biomass in the decomposition pools standmass = 0.0 flatmass = 0.0 harvmass = harvmass + stand cropht = 0.0 do 50 i = 1,mnbpls dstand(i) = 0.0 dflat(i) = 0.0 dstemht(i) = 0.0 50 continue endif c***************************************************************** if (BTEST(flag,5)) then c print *, 'Flag 5 is on' c print *, 'Remove all flat residue (decomp pools only)' do 60 i=1,(mnbpls) dflat(i) = 0.0 60 continue endif c***************************************************************** if (BTEST(flag,6)) then c print *, 'Flag 6 is on' c print *, 'Remove nothing just increment pools with killed crop' c Remove nothing. Put current crop into most recent decomp pool. Note c there is no need to pass cutht and other percentages if this is what c is being done. May want to implement this in another routine somewhere do 70 lay=1,nslay(sr) bgmass(lay)=0.0 70 continue standmass=stand flatmass=0.0 endif c***************************************************************** if (BTEST(flag,7)) then c print *, 'Flag 7 is on' c Kill root mass and transfer it to the first decomp pool c This will need to be done along with several process above. c For you kill the crop and remove it the rootmass needs to be c placed into the decomp pools c The following code allocates rootmass to each layer based on c a function. The function currently used is in func.for and is c a straight line which represents a triangular distribution c for the root mass. This function can be changed. The c subroutine trapzd is an algorithm which integrates a function c over the limits a to b (see description in trapzd.for). The c function rootlay determines the # of layers a root is in. rtlay=rootlay(rootdt,aszlyt(1,sr),nslay(sr)) dd=0.0 ss=0.0 s=0.0 ad=0.0 bd=0.0 do 32 k=1,rtlay dd=dd+aszlyt(k,sr) 32 continue c print *,'dd=',dd do 31 j=1,4 call trapzd(0.0,dd,ss,j) 31 continue c print *,'ss=',ss do 33 k=1,rtlay c print *,aszlyt(k,sr) ad=bd bd=bd+aszlyt(k,sr) c print *,ad,bd do 34 j=1,4 call trapzd(ad,bd,s,j) 34 continue c ratio is calculated by taking the area in a rectangle and c subtracting off the area under the line specified in func.for. ratio(k)=(0.5*dd*(bd-ad)-s)/(0.5*dd**2-ss) c print *,ratio(k) s=0.0 33 continue c Update the rootmass in each layer based on the area ratios. c The integration is done from bottom to top and the ratio is also c calculated this way so when updating rtmass need to go from top c to bottom thus "(rtlay-lay+1)" c print *, 'rootmass from remove', roott do 35 lay=1,rtlay rtmass(lay)=roott*ratio(rtlay-lay+1) c print *, 'rtmass from remove', rtmass(lay) 35 continue endif c***************************************************************** c Update decomp pools with the "temporary" variables, flatmass, c standmass, rtmass(lay), bgmass(lay) and perform the kill process c (increment the pools) by calling dechrv.for. We need subregion c info for this call however (Do we pass it here????) c c*********************TEST CODE******************************** c print *, 'THE CURENT SUBREGION FROM REMOVE IS', sr c do 999 lay = 1,nslay(sr) c print *, 'FROM REMOVE ',harvmass c print *, 'FROM REMOVE droot(2,lay)', droot(2,lay) c999 continue c*********************TEST CODE******************************* c print *, 'NOW CALLING DECHRV.FOR FROM REMOVE.FOR' call dechrv(sr,cropname,standmass,flatmass,bgmass(1), & rtmass(1),cutht,croppop) end