c
      subroutine   doproc
     i                      (sr)
c
c     + + + PURPOSE + + +
c     Doproc is called when a process line is found in the prfind
c     subroutine. Doproc reads in any coefficients associated with the
c     process. Doproc then makes a call to a subroutine which, in turn,
c     modifies the state variables to mimic the effects of doing the
c     process.
c
c     + + + KEYWORDS + + +
c     tillage, process, management
c
c     + + + PARAMETERS AND COMMON BLOCKS + + +
*$noereference
      include 'p1werm.inc'
      include 'm1flag.inc'
      include 'm1sim.inc'
      include 'm1dbug.inc'
      include 's1layr.inc'
      include 's1layd.inc'
      include 's1agg.inc'
      include 's1sgeo.inc'
      include 's1phys.inc'
      include 's1surf.inc'
      include 's1dbh.inc'
      include 's1dbc.inc'
      include 'c1gen.inc'
      include 'c1db1.inc'
      include 'c1geom.inc'
      include 'c1glob.inc'
      include 'c1info.inc'
      include 'c1mass.inc'
      include 'h1hydro.inc'
      include 'h1db1.inc'
      include 'decomp/decomp.inc'
      include 'manage/oper.inc'
      include 'manage/asd.inc'
      include 'manage/man.inc'
      include 'manage/harv.inc'
      include 'd1mass.inc'
      include 'd1glob.inc'
*$reference
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer sr
c     + + + ARGUMENT DEFINITIONS + + +
c     sr - the number of subregions
c
c     + + + ACCESSED COMMON BLOCK VARIABLE DEFINITIONS + + +
c
c     acdpop    - crop seeding density
c     acrlai    - crop leaf area index
c     aheaep    - soil air entery potential
c     ahrwc     - soil water content (mass bases)
c     ahrwca    - available soil water content
c     ahrwcf    - 1/3 bar soil water content
c     ahrwcs    - saturation soil water content
c     ahrwcw    - 15 bar soil water content
c     am0cgf    - flag to call crop growth between plant and harvest
c     am0hrvfl  - flag to determine if the crop is perennial and killed
c                 during a harvest.  Values are
c                 0 - no harvesting being done
c                 1 - perennial crop which is NOT killed
c                 2 - annual or perennial crop which is killed
c     am0tdb    - flag for outputing debug information to a file
c                 0 - no output
c                 1 - output to file ../out/tdbug.out
c     am0tfl    - flag for outputing management operations to a file
c                 0 - no output
c                 1 - output to file ../out/manage.out
c     as0ags    - aggr. size geom. mean std. dev.
c     as0ph     - soil Ph
c     asargo    - ridge orientation (clockwise from true North) (degrees)
c     ascmg     - magnesium ion concentration
c     ascna     - sodium ion concentration
c     asdadg    - aggregrate density
c     asdblk    - soil layer bulk density
c     aseags    - dry aggregrate stability
c     asfcce    - fraction of calcium carbonate
c     asfcec    - cation exchange capcity
c     asfcla    - fraction of clay
c     asfesp    - exchangable sodium percentage
c     asfnoh    - organic N concentration of humus
c     asfom     - fraction of organic matter
c     asfpoh    - organic P concentration of humus
c     asfpsp    - fraction of fertilizer P that is labile
c     asfsan    - fraction of sand
c     asfsil    - fraction of silt
c     asfsmb    - sum of bases
c     aslagm    - aggr. size geom. mean diameter (mm)
c     aslagn    - min. aggr. size of each layer (mm)
c     aslagx    - max aggr. size of each layer (mm)
c     aslrr     - Allmaras random roughness parameter (mm)
c     asxrgs    - ridge spacing (mm)
c     asxrgw    - ridge width (mm)
c     aszlyt    - soil layer thickness (mm)
c     aszrgh    - ridge height (mm)
c     prcode    - the process id number
c     prname    - the process name

c     + + + LOCAL VARIABLES + + +
      integer rtn,flag,rdgflag
      integer output
      real    massf (msieve+1,mnsz)
      real    alpha, beta, u
      real    perctill, intens, rrimpl
      real    crstrmd
      real    grainp,cropp,decompp,bgp
      real    buryf,liftf,fltcoef
      real    rdght,rdgwt,rdgspac,rdgdir,dikeht,dikespac
c
c     + + + LOCAL VARIABLE DEFINITIONS + + +
c
c     alfa     - parameter reflecting the breakage of all soil
c                aggregrates regardless of size
c     beta     - parameter reflecting the uneveness of breakage among
c                aggregrates in different size classes
c     bgp      - percent of below ground mass to be removed
c     buryf    - fraction of mass to be buried
c     cropp    - percent of crop to be removed
c     crstrmd  - fraction of the crust removed during a tillage operation
c     decompp  - percent if decomp pool material to be removed
c     dikeht   - dike height (mm)
c     dikespac - dike spacing (mm)
c     flag     - flag used in the remove subroutine which determines
c                 what needs to be removed
c     fltcoef  - flattening coefficient of an implement
c     grainp   - percent of grain to be removed
c     harvflag - flag indicating a harvest
c     intens   - tillage intensity factor
c     liftf    - fraction of mass to be lifted
c     massf    - mass fractions of aggregrates within sieve cuts
c                 (sum of all the mass fractions are expected to be 1.0)
c     output   - flag used to indicate whether management output is needed
c     perctill - fraction of the surface tilled
c     rdght    - ridge height (mm)
c     rdgdir   - ridge orientation clockwise from true north
c     rdgflag  - flag indicating whether ridge modifications are needed
c     rdgspac  - ridge spacing (mm)
c     rdgwt    - ridge width (mm)
c     rrimpl   - assigned nominal RR value for the tillage operation (mm)
c     rtn      - used with the getr function
c     u        - mixing coefficient (0 <= u <= 1)
c
c     + + + SUBROUTINES CALLED + + +
c
c     asd2m     - aggregate size distribution to mass fraction converter
c     burylift  - performs the biomass transfer either into the soil
c                 or from the soil to the surface (deals with decomp
c                 pools only
c     crush     - the crushing process
c     crust     - destroys a cursted surface depending on the operation that
c                 is performed
c     invert    - performs an inversion of the vertical soil layers
c     loosn     - performs the loosen/compact process
c     m2asd     - mass fraction to aggregate size distribution converter
c     mix       - mixes components in specified layers
c     orient    - calculates the oriented roughness
c     remove    - performs the biomass removal during a harvest, burn, etc.
c                 and updates the decomposition pools accordingly.
c                 Also does the 'cut' and 'kill' processes.
c     rough     - calculated the post tillage random roughness
c     tdbug     - subroutine which writes out variables for debugging purposes
c
c     + + + FUNCTION DECLARATONS + + +
      integer getr, tillay
c
c     + + + DATA INITIALIZATIONS + + +
c     None
c
c     + + + OUTPUT FORMATS + + +
2015     format (' Process code ',i2,1x,'Process '1x,a20 )
c
c     + + + END SPECIFICATIONS + + +

      if (am0tdb .eq. 1) then
         open(29,file='../out/tdbug.out',access='sequential',
     &        status='unknown')
      end if
      if (am0tfl .eq. 1) then
         open(15,file='../out/manage.out',access='sequential',
     &        status='unknown')
      end if
c     mpos should always be pointing to the 2nd char of mline here
      rtn = getr(prcode,prcode,prcode,1,'i')
      rtn = getr(prname,prname,prname,1,'c')
      write (15,2015) prcode,prname

c      print*, 'SR',sr,' Performing process:',
c     &        prcode,' ',prname
c
c     fortan equivalent of a case statement
      go to (01,02,03,04,05,06,07,08,09,10,11,12) prcode
c
c     default case
      print*, 'SR',sr,' Process:', prcode, ' code not found.'
      go to 1000
c
c     process calls follow (currently only 1 implemented)
c
c-----START crushing process (process code 01)
 01   rtn=getr(alpha,alpha,alpha,1,'r')
      if (getr(beta,beta,beta,1,'r').gt.0) then
        print*,'ERROR in doproc'
        stop
      endif
c
c    pre-process stuff
c
c     Convert ASD from modified log-normal to sieve classes
            if (am0tdb .eq. 1) then
               write (29,*)
               write (29,*) '//Before crushing process//'
               output=1
               call tdbug(sr, nslay(sr),output)
            end if
      call asd2m(aslagn(1,sr), aslagx(1,sr), aslagm(1,sr),
     &           as0ags(1,sr), nslay, massf)
c
c     do process
c
      call crush(alpha, beta, tlayer, massf)
c
c     post-process stuff
c
c     Convert ASD back from sieve classes to modified log-normal
      call m2asd(massf, nslay,
     &  aslagn(1,sr), aslagx(1,sr), aslagm(1,sr), as0ags(1,sr))
            if (am0tdb .eq. 1) then
               write (29,*) '//After crushing process//'
               output=1
               call tdbug(sr, nslay(sr),output)
            end if
      go to 1000
c-----END crushing process (process code 01)
c
c-----START loosening process (process code 02)
c     pre-process stuff
 02   rtn=getr(u,u,u,1,'r')
c     do process
            if (am0tdb .eq. 1) then
               write (29,*)
               write (29,*) '//Before loosening process//'
               output=2
               call tdbug(sr, nslay(sr),output)
            end if
      call loosn(u,tlayer,
     &           asdblk(1,sr),asdsbk(1,sr),aszlyt(1,sr))
            if (am0tdb .eq. 1) then
               write (29,*) '//After loosening process//'
               output=2
               call tdbug(sr, nslay(sr),output)
            end if
c     post-process stuff
      go to 1000
c-----END loosening process (process code 02)
c
c-----START mixing process (process code 03)
c     pre-process stuff
c     read the mixing coefficient from the data file
 03   rtn=getr(u,u,u,1,'r')
c     do process
            if (am0tdb .eq. 1) then
               write (29,*)
               write (29,*) '//Before mixing process//'
               write (29,*) 'Tillage layer depth is', tlayer
               output=3
               call tdbug(sr, nslay(sr),output)
            end if
c      do 773 i=1,5
c      print *,admr(1,i,sr)
c773   continue
      call mix(u,tlayer,asdblk(1,sr),aszlyt(1,sr),asfsan(1,sr),
     &    asfsil(1,sr),asfcla(1,sr),as0ph(1,sr),ascmg(1,sr),
     &    ascna(1,sr),asfcce(1,sr),asfcec(1,sr),asfesp(1,sr),
     &    asfom(1,sr),asfnoh(1,sr),asfpoh(1,sr),asfpsp(1,sr),
     &    asfsmb(1,sr),asdagd(1,sr),aseags(1,sr),ahrwc(1,sr),
     &    aheaep(1,sr),ahrwcw(1,sr),ahrwcf(1,sr),ahrwca(1,sr),
     &    ahrwcs(1,sr),
     &    admr(1,1,sr),admb(1,1,sr),
     &    massf)
c      do 774 i=1,5
c     print *,'after call to mix!!!!!',admr(1,i,sr)
c774   continue
            if (am0tdb .eq. 1) then
               write (29,*) '//After mixing process//'
               output=3
               call tdbug(sr, nslay(sr),output)
            end if
c     post-process stuff
      go to 1000
c-----END mixing process (process code 03)
c
c-----START planting process (process code 04)
 04   rtn=getr(ac0id,ac0id,ac0id,1,'i')
      rtn=getr(aszrgh,aszrgh,aszrgh,1,'r')
      rtn=getr(asxrgw,asxrgw,asxrgw,1,'r')
      rtn=getr(asxrgs,asxrgs,asxrgs,1,'r')
      rtn=getr(asargo,asargo,asargo,1,'r')
      if (getr(acdpop,acdpop,acdpop,1,'r').gt.0) then
        print*,'ERROR in doproc'
        stop
      endif
c      print*, 'Crop Number',ac0id(sr)
c     pre-process stuff
c     do process
c     set flag for crop initialization - jt
        am0cif = .true.
c     set crop growth flag on - jt
        am0cgf = .true.
c     added the following 1 line to enable uotput of end-of-season
c     crop parameters : retta (1/24/96)
      call cinput
c     post-process stuff
      go to 1000
c-----END planting process (process code 04)
c
c-----START harvest process (process code 05)
c 05   print*, 'SR',sr,' Process:',prcode,' is ',prname
c     pre-process stuff
c      set am0hrvfl
c                 0 - no harvesting being done
c                 1 - perennial crop which is NOT killed
c                 2 - annual or perennial crop which is killed
 05   rtn=getr(am0hrvfl,am0hrvfl,am0hrvfl,1,'i')
c     do process
      if (am0hrvfl.gt.1) then
c        need to stop the crop growth (ie. stop calling crop submodel)
c        am0cgf is turned to .false. in the GROWTH sub of CROP:retta:1/24/96
c        am0cgf = .false.
         acrlai(sr) = 0.0
      else
      endif
c     post-process stuff
      harvdate = am0jd
c      print *, 'julian harvest date',harvdate
      go to 1000
c-----END harvest process (process code 05)
c
c-----START killing process (process code 06)
c 06   print*, 'SR',sr,' Process:',prcode,' is ',prname
c     pre-process stuff
c     do process
c     call kill()
c     post-process stuff
c     turn of crop submodel
 06   am0cgf = .false.
      acrlai(sr) = 0.0
c     need to call the remove process and specify what needs to
c     go into the decomp pools if nothing is removed (ie pesticide
c     application) use remove flag 6
c     transfer residue pools
c      call dechrv(sr)
      go to 1000
c-----END killing process (process code 06)
c
c-----START random roughness process (process code 07)
c 07   print*, 'SR',sr,' Process:',prcode,' is ',prname
c     pre-process stuff
c     read the random roughness for the implement, tillage intensity
c     factor, and the fraction of the surface tilled from the data file
 07   rtn=getr(rrimpl,rrimpl,rrimpl,1,'r')
      rtn=getr(intens,intens,intens,1,'r')
      rtn=getr(perctill,perctill,perctill,1,'r')
c     do process
c     set flag for surface modification
      am0til = .true.
            if (am0tdb .eq. 1) then
               write (29,*)
               write (29,*) '//Before random roughness process//'
               output=4
               call tdbug(sr, nslay(sr),output)
            end if
      call rough(rrimpl,intens,perctill,aslrr(sr))
            if (am0tdb .eq. 1) then
               write (29,*) '//After random roughness process//'
               output=4
               call tdbug(sr, nslay(sr),output)
            end if
c     post-process stuff
      go to 1000
c-----END random roughness process (process code 07)
c
c
c-----START crust breakdown process (process code 08)
c 08   print*, 'SR',sr,' Process:',prcode,' is ',prname
c     pre-process stuff
 08   rtn=getr(crstrmd,crstrmd,crstrmd,1,'r')
      rtn=getr(perctill,perctill,perctill,1,'r')
c     do process
            if (am0tdb .eq. 1) then
               write (29,*)
               write (29,*) '//Before crust breakdown process//'
               output=5
               call tdbug(sr, nslay(sr),output)
            end if
      call crust(crstrmd,perctill,asfcr(sr),asflos(sr))
            if (am0tdb .eq. 1) then
               write (29,*) '//After crust breakdown process//'
               output=5
               call tdbug(sr, nslay(sr),output)
            end if
c     post-process stuff
      go to 1000
c-----END crust breakdown process (process code 08)
c
c
c
c-----START inversion process (process code 09)
c 09   print*, 'SR',sr,' Process:',prcode,' is ',prname
c     pre-process stuff
c     do process
  09        if (am0tdb .eq. 1) then
               write (29,*)
               write (29,*) '//Before inversion process//'
               output=6
               call tdbug(sr, nslay(sr),output)
            end if
      call invert(tlayer,asdblk(1,sr),aszlyt(1,sr),asfsan(1,sr),
     &    asfsil(1,sr),asfcla(1,sr),as0ph(1,sr),ascmg(1,sr),
     &    ascna(1,sr),asfcce(1,sr),asfcec(1,sr),asfesp(1,sr),
     &    asfom(1,sr),asfnoh(1,sr),asfpoh(1,sr),asfpsp(1,sr),
     &    asfsmb(1,sr),asdagd(1,sr),aseags(1,sr),ahrwc(1,sr),
     &    aheaep(1,sr),ahrwcw(1,sr),ahrwcf(1,sr),ahrwca(1,sr),
     &    ahrwcs(1,sr),
     &    admr(1,1,sr),admb(1,1,sr),
     &    massf)
            if (am0tdb .eq. 1) then
               write (29,*) '//After inversion process//'
               output=6
               call tdbug(sr, nslay(sr),output)
            end if
c     post-process stuff
      go to 1000
c-----END inversion process (process code 09)
c
c
c-----START biomass remove process (process code 10)
c 10   print*, 'SR',sr,' Process:',prcode,' is ',prname
c     pre-process stuff
 10   rtn=getr(grainp,grainp,grainp,1,'r')
      rtn=getr(cropp,cropp,cropp,1,'r')
      rtn=getr(decompp,decompp,decompp,1,'r')
      rtn=getr(cutht,cutht,cutht,1,'r')
      rtn=getr(bgp,bgp,bgp,1,'r')
      rtn=getr(flag,flag,flag,1,'i')
c   check to see if cutht is negitive if it is then calculate the
c   number of layers to go down using tillay (note tillay needs a positive
c   number so this is done here.  If the cutht is positive then nlay=0
      if (cutht.lt.0.0) then
         cutht=-1.0*cutht
         tlayer = tillay(cutht,aszlyt(1,sr),nslay(sr))
      else
         tlayer = 0
      endif
c     do process
c  Not sure about adzhht(1,sr) which is supposed to be the harvest height

c  NOTE need the crop root properties for layer and subregion, also need
c  crop yield properties for subregions.  CHECK THESE !!!!!!!!!!!!!!!!!!
c  and other crop properties.  ANH.
c
            if (am0tdb .eq. 1) then
               write (29,*)
               write (29,*) '//Before biomass remove process//'
               output=7
               call tdbug(sr, nslay(sr),output)
            end if
      call remove(sr,grainp,cropp,decompp,cutht,bgp,
     &    admst(1,sr),admf(1,sr),admr(1,1,sr),admb(1,1,sr),
     &    acmst(sr),acmrt(sr),acmyld(sr),tlayer,
     &    acz(sr),aczrtd(sr),stmht(1,sr),
     &    ac0nam(sr),addstm(1,sr),flag)
            if (am0tdb .eq. 1) then
               write (29,*) '//After biomass remove process//'
               output=7
               call tdbug(sr, nslay(sr),output)
            end if
c     post-process stuff
      go to 1000
c-----END biomass remove process (process code 10)
c
c-----START oriented roughness process (process code 11)
c 11   print*, 'SR',sr,' Process:',prcode,' is ',prname
c     pre-process stuff
c     read the oriented roughness parameters for the implement
 11   rtn=getr(rdght,rdght,rdght,1,'r')
      rtn=getr(rdgwt,rdgwt,rdgwt,1,'r')
      rtn=getr(rdgspac,rdgspac,rdgspac,1,'r')
      rtn=getr(rdgdir,rdgdir,rdgdir,1,'r')
      rtn=getr(dikeht,dikeht,dikeht,1,'r')
      rtn=getr(dikespac,dikespac,dikespac,1,'r')
      rtn=getr(depth,depth,depth,1,'r')
      rtn=getr(rdgflag,rdgflag,rdgflag,1,'i')
c     do process
c     set flag for surface modification
      am0til = .true.
            if (am0tdb .eq. 1) then
               write (29,*)
               write (29,*) '//Before oriented roughness process//'
               output=8
               call tdbug(sr, nslay(sr),output)
            end if
      call orient(sr,rdght,rdgwt,rdgspac,rdgdir,dikeht,
     &            dikespac,depth,rdgflag)
            if (am0tdb .eq. 1) then
               write (29,*) '//After oriented roughness process//'
               output=8
               call tdbug(sr, nslay(sr),output)
            end if
c     post-process stuff
      go to 1000
c-----END oriented roughness process (process code 11)
c
c-----START biomass cutting process (process code 11)
c 11   print*, 'SR',sr,' Process:',prcode,' is ',prname
c     pre-process stuff
c      rtn=getr(cutht,cutht,cutht,1,'r')
c     do process
c      call cut(cutht,adma(0,sr))
c     post-process stuff
c      go to 1000
c-----END biomass cutting process (process code 11)
c
c
c-----START biomass bury/lift process (process code 12)
c 12   print*, 'SR',sr,' Process:',prcode,' is ',prname
c     pre-process stuff
 12   rtn=getr(buryf,buryf,buryf,1,'r')
      rtn=getr(liftf,liftf,liftf,1,'r')
      rtn=getr(fltcoef,fltcoef,fltcoef,1,'r')
c     do process
            if (am0tdb .eq. 1) then
               write (29,*)
               write (29,*) '//Before bury/lift process//'
               output=9
               call tdbug(sr, nslay(sr),output)
            end if
      call burylift(tlayer,admf(1,sr),admst(1,sr),admr(1,1,sr),
     &              admb(1,1,sr),buryf,liftf,fltcoef)
            if (am0tdb .eq. 1) then
               write (29,*) '//After bury/lift process//'
               output=9
               call tdbug(sr, nslay(sr),output)
            end if
c     post-process stuff
      go to 1000
c-----END biomass bury/lift process (process code 12)
c
 1000 return
      end
c
c$Log: not supported by cvs2svn $
c Revision 1.9  1997/04/14  20:15:23  retta
c added line to output crop parameters
c
c Revision 1.8  1995/12/07  21:59:10  hawkins
c added include file /manage/harv.inc and the variable harvdate which contains
c the Julian date that the last harvest occured on.
c
c Revision 1.7  1995/12/07  15:30:53  hawkins
c removed duplicate line containing am0cif.  changed harvflg to am0hrvfl which is
c now global.
c
c Revision 1.6  1995/11/15  22:50:04  jt
c Added statement to set 'am0nkfl' to .true. if there is a non-killing
c harvest.  This should remain .true. until planting of a new crop.
c
c Revision 1.5  1995/10/19  18:09:50  hawkins
c added comments and variable definitions.  also added some more varibles
c to be printed in tdbug.for
c
c Revision 1.4  1995/09/13  15:54:40  wagner
c Necessary changes made to allow FORTRAN src files (*.for) to use the
c extended FORTRAN include statement rather than the MICROSOFT $INCLUDE
c directive as previously used.  This is required to allow use of other
c FORTRAN compilers.
c
c Changes have been made to the prologue.mk, epilogue.mk, and the Unix
c master startup.mk files as well as the src files.
c
c Revision 1.3  1995/09/02  18:20:45  hawkins
c updated doproc.for
c
c Revision 1.1.1.1  1995/01/18  04:19:54  wagner
c Initial checkin
c
c Revision 1.11  1994/09/01  22:28:22  jt
c *** empty log message ***
c
c Revision 1.10  1994/05/18  20:14:09  dudley
c starting to add new processes (crop, harvest, ...)
c
c Revision 1.9  1992/10/18  17:09:48  wagner
c Cleaned up the routine some.
c
c Revision 1.8  1992/10/13  08:31:05  wagner
c Major changes involving reading management file.
c
c Revision 1.7  1992/10/12  02:15:52  wagner
c *** empty log message ***
c
c Revision 1.6  1992/10/11  05:25:26  wagner
c Messed with crush not being able to be found under MSDOS.
c Libraries not included in correct order.
c
c Revision 1.5  1992/10/10  21:15:07  wagner
c Converted TILLAGE submodel to MANAGEMENT submodel.
c
c Revision 1.4  1992/10/05  16:27:16  jt
c removed redundant declaration.
c
c Revision 1.3  1992/06/29  19:56:27  dudley
c add fortran coding conventions