C=======================================================================
C  SG_GROSUB, Subroutine
C
C  Determines sorghum growth.
C-----------------------------------------------------------------------
C  Revision history
C
C                 Written
C  02/07/1993 PWW Header revision and minor changes
C  02/07/1993 PWW Added switch common block
C  06/21/1991 JTR/BDB Updated PCARB calculation
C  07/31/2002 WDB Converted to modular format
C. 07/31/2002 WDB Added pest damage, SLPF, satfac
C  03/12/2003 CHP Changed senescence variable to composite (SENESCE)
C                   as defined in ModuleDefs.for
C  03/30/2006 CHP Added composition of senesced matter for SOM modules
C  04/21/2007 GH  Externalized stem partitioning STPC=0.1
C  04/21/2007 GH  Externalized root partitioning RTPC=0.25
C  05/31/2007 GH  Added P-model (unfinished)
C  08/26/2011 GH  Update early partitioning and decrease root distribution
C  08/10/2015 GH  Check for negative root growth ISTAGE = 4
C  02/07/2018 MA  Externalized initial leaf area A= 6000
C-----------------------------------------------------------------------
C  INPUT  : None
C
C  LOCAL  : NSINK,NPOOL1,NPOOL2,NPOOL,NSDR,I,PAR,TT,PCARB,PRFT,TTMP,PC,TI,
C           XTN,A,RTR,TC1,TC2,PLATN,PLAGT,GRF,TLG,FLG,GGG,RGFILL,WSTR,FSTR,
C           GROPAN,RGNFIL,RMNC,XNF,TNLAB,RNLAB,RNOUT,SLFW,SLFN,SLFC,SLFT,PLAS
C
C  OUTPUT : None
C-----------------------------------------------------------------------
C  Called : SG_CERES
C
C  Calls  : SG_NFACT SG_NUPTAK
C-----------------------------------------------------------------------

      SUBROUTINE SG_GROSUB (DYNAMIC,STGDOY,YRDOY,
     & AGEFAC, BIOMAS, CARBO, CNSD1,CNSD2, CO2X, CO2Y,
     & CO2, CSD2, CUMDTT, CUMPH, DLAYR,DM, DTT,
     & GPP, GRAINN, GROLF, GRORT, GROSTM, ICSDUR, ISTAGE,
     & ISWNIT, ISWWAT, LAI, LEAFNO, LFWT, LL, LWMIN, NDEF3,
     & NFAC, NLAYR, NH4,NSTRES, NO3, P1, P3, P4, P5, PAF, PANWT,
     & PDWI, PGC, PGRORT, PHINT, PLA, PLAN, PLAG, PLAO, PLATO,
     & SLA1, SLA2,SLA3,
     & PLAY, PLTPOP, PTF, RANC, RCNP, RLV,ROOTN, ROWSPC, RTWT,
     & SAT,SEEDRV, SENLA, SHF, SLAN, SLW, SRAD,
     & STMWT, STOVN, STOVWT, SW, SWMAX, SWMIN, SUMDTT, SUMRTR,
     & SWFAC, TANC, TBASE, TCNP,TEMF, TEMPM, TDUR, TILN, TILFAC,
     & TMAX, TMFAC1, TMIN, TMNC, TRNU,TSIZE, TURFAC,
     & XN,XSTAGE, EOP, TRWUP, RWUEP1,UNO3,UNH4,
     & PRFTC,RGFIL,PORMIN,PARSR,RUE,SLPF,SATFAC,FSLFW,FSLFN,
     & ASMDOT,WLIDOT,WSIDOT,WRIDOT,PPLTD,SWIDOT,ISWDIS, SENESCE,
     & KG2PPM,STPC,RTPC,PANTH,PFLOWR,CUMP4,A,
     & FILECC,
     & DS, ISWPHO, SPi_AVAIL, PUptake,
     & RTDEP, SeedFrac, FracRts, VegFrac, YRPLT,
     & PConc_Shut, PConc_Root, PConc_Shel, PConc_Seed,
     & PSTRES1, PSTRES2, MDATE, PCNVEG, PODWT, RTWTO, SDWT,
     & STMWTO, WTLF, FSLFP)

      USE ModuleDefs
      USE Interface_SenLig_Ceres

      IMPLICIT  NONE

      SAVE

      INTEGER     DYNAMIC

      REAL        AGEFAC, ASMDOT, BIOMAS, CARBO, CNSD1, CNSD2
	REAL        CO2X(10), CO2Y(10), CO2, CSD2, CUMDTT, CUMPH
      REAL        CUMP4, CURV, DM, DTT

      REAL        EOP
      REAL        EP1
      REAL        FSLFW
      REAL        FSLFN
      REAL        GPP
      REAL        GRAINN
      REAL        GROLF
      REAL        GRORT
      REAL        GROSTM
      INTEGER     ICSDUR
      INTEGER     ISTAGE
      CHARACTER   ISWDIS*1
      CHARACTER   ISWNIT*1
      CHARACTER   ISWWAT*1
      REAL        KG2PPM(NL)
      REAL        LAI
      REAL        LAT
      INTEGER     LEAFNO
      REAL        LFWT
      REAL        LWMIN
      REAL        NDEF3
      REAL        NFAC
      REAL        NSTRES
      REAL        P1, P3, P4, P5, PFLOWR
      REAL        PAF
      REAL        PANWT
      REAL        PDWI
      REAL        PGC
      REAL        PGRORT
      REAL        PHINT
      REAL        PLA
      REAL        PLAN
      REAL        PLAG
      REAL        PLAO
      REAL        PLATO
      REAL        PLAY
      REAL        PLTPOP
      REAL        PRFTC(4)
      REAL        PTF
      REAL        RANC
      REAL        RCNP
      REAL        RGFIL(4)
      REAL        ROOTN
      REAL        ROWSPC
      REAL        RTWT
      REAL        RWUEP1
      REAL        SEEDRV
      REAL        SENLA
      REAL        SLA
      real        SLA1,SLA2, SLA3
      REAL        SLAN
      REAL        SLW
      REAL        SRAD
      REAL        STMWT
      REAL        STOVN
      REAL        STOVWT
      REAL        SWMAX
      REAL        SWMIN
      REAL        SUMDTT
      REAL        SUMRTR
      REAL        SWFAC
      REAL        TANC
      REAL        TBASE
      REAL        TCNP
      REAL        TEMF
      REAL        TEMPM
      REAL        TDUR
      REAL        TILN, TILFAC
      REAL        TMAX
      REAL        TMFAC1(8)
      REAL        TMIN
      REAL        TMNC
      REAL        TRWUP
      REAL        TSIZE
      REAL        TURFAC
      REAL        UNO3(NL)
      REAL        UNH4(NL)

      REAL        XN
      REAL        XSTAGE
C      PEST DAMAGE
      REAL        WLIDOT
      REAL        LAIDOT
      REAL        WSIDOT
      REAL        WRIDOT
      REAL        PPLTD
      REAL        SWIDOT
      REAL        STPC,RTPC
     	REAL        PANTH

C-----------------------------------------------------------------
C   Local Variables
C-----------------------------------------------------------------

      INTEGER   I
      REAL      NSINK,NPOOL1,NPOOL2,NPOOL,NSDR,GCS
      REAL      TT,PCARB,PRFT,TTMP,PC,TI,XTN,A,RTR,TC1,TC2,PLATN,TCON
      REAL      PLAGT,GRF,TLG,FLG,GGG,RGFILL,WSTR,FSTR,GROPAN,RGNFIL
      REAL      RMNC,XNF,TNLAB,RNLAB,RNOUT,SLFW,SLFN,SLFC,SLFT,PLAS
      REAL      TABEX,PCO2

!      SAVE      GCS
C--------------------------------------------------------------------
C     Variables required in SG_NFAC but not used in SG_GROSUB
C--------------------------------------------------------------------
      REAL DLAYR(NL)
      INTEGER L
      REAL LIFAC
      REAL LL(NL)
      REAL NH4(NL)
      INTEGER NLAYR
      REAL NO3(NL)
      REAL PAR
      REAL PARSR
      REAL SLPF
      REAL PORMIN
      REAL RLV(NL)
      REAL RUE
      REAL SAT(NL)
      REAL SATFAC
      REAL SHF(NL)
      REAL SUMEX
      REAL SUMRL
      REAL SW(NL)
      REAL SWEXF
      REAL TRNU
      REAL TSS(NL)

!----------------------------------------------------------------------
      TYPE (ResidueType) SENESCE
!     CHP 3/31/2006
!     Proportion of lignin in STOVER and Roots
      REAL PLIGLF, PLIGRT

!     Added to send messages to WARNING.OUT
      CHARACTER*78 MESSAGE(10)
      CHARACTER*6  ERRKEY
      PARAMETER    (ERRKEY='SG_GRO')

!-GH  Added for P model
      CHARACTER*1  ISWPHO
      CHARACTER*92 FILECC

      INTEGER     YRPLT, MDATE
      INTEGER     STGDOY(20),YRDOY

      REAL        DS(NL), RTDEP, FracRts(NL)
      REAL        SPi_AVAIL(NL), PUptake(NL)
      REAL        FSLFP, PStres1
      REAL        PStres2, SeedFrac, VegFrac, SLFP
      REAL        PConc_Shut, PConc_Root, PConc_Shel, PConc_Seed
      REAL        CumLeafSenes    !today's cumul. leaf senescence
      REAL        PCNVEG, PODWT, RTWTO, SDWT, Stem2Ear, STMWTO, WTLF

C--------------------------------------------------------------------
C              DYNAMIC = RUNINIT OR SEASINIT
C--------------------------------------------------------------------
      IF(DYNAMIC .EQ. RUNINIT .OR. DYNAMIC .EQ. SEASINIT) THEN

        CALL SenLig_Ceres(PLIGLF=PLIGLF, PLIGRT=PLIGRT)

         XSTAGE = 0.0
         AGEFAC = 0.0
         BIOMAS = 0.0
         CARBO  = 0.0
         DM     = 0.0
         GPP    = 0.0
         GRAINN = 0.0
         GROLF  = 0.0
         GRORT  = 0.0
         GROSTM = 0.0
         LAI    = 0.0
         LEAFNO = 0
         LFWT   = 0.0
         LWMIN  = 0.0
         PAF    = 0.0
         PANWT  = 0.0
         PDWI   = 0.0
         PGC    = 0.0
         PGRORT = 0.0
         PLA    = 0.0
         PLAN   = 0.0
         PLAG   = 0.0
         PLAO   = 0.0
         PLATO  = 0.0
         PTF    = 0.0
         RLV    = 0.0
         ROOTN  = 0.0
         RTWT   = 0.0
         SENLA  = 0.0
         SLAN   = 0.0
         SLW    = 0.0
         STMWT  = 0.0
         STOVN  = 0.0
         STOVWT = 0.0
         TILN   = 1.0
         TRNU   = 0.0
         TSIZE  = 0.0
         XN     = 0.0
         CumLeafSenes = 0.0
         Stem2Ear = 0.0
C
C-GH     Check for appropriate equations to be added to the code
C
         IF (ISWNIT .NE. 'N') THEN
           CALL SG_NFACT(DYNAMIC,
     &       AGEFAC, CNSD1, CNSD2, ISTAGE, NDEF3, NFAC,
     &       NSTRES, RANC, RCNP, TANC, TCNP, TMNC, XSTAGE)

         ELSE
           AGEFAC = 1.0
           NSTRES = 1.0
           NDEF3 = 1.0
           NFAC = 1.0
         ENDIF

        CALL SG_NUPTAK(
     %    RANC, ROOTN,RTWT,TANC,STOVN,STOVWT,TRNU,NLAYR,
     %    RLV,NO3,NH4,PDWI,TCNP,UNO3,UNH4,
     %    XSTAGE,RCNP,PGRORT,PLTPOP,SW,LL,SAT,DLAYR,
     %    SHF,PTF, SENESCE, KG2PPM, PLIGRT)

        CALL P_Ceres (DYNAMIC, ISWPHO,                    !Input
     &    CumLeafSenes, DLAYR, DS, FILECC, MDATE, NLAYR,  !Input
     &    PCNVEG, PLTPOP, PODWT, RLV, RTDEP, RTWTO,       !Input
     &    SDWT, SWIDOT, SeedFrac, SPi_AVAIL, Stem2Ear,    !Input
     &    STMWTO, VegFrac, WLIDOT, WRIDOT, WSIDOT,        !Input
     &    WTLF, YRPLT,                                    !Input
     &    SENESCE,                                        !I/O
     &    PConc_Shut, PConc_Root, PConc_Shel, PConc_Seed, !Output
     &    PStres1, PStres2, PUptake, FracRts)             !Output

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C
C                     DYNAMIC = RATE
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      ELSEIF(DYNAMIC.EQ.RATE) THEN

!         Daily senescence
          SENESCE % ResWt  = 0.0
          SENESCE % ResLig = 0.0
          SENESCE % ResE   = 0.0

C--------------------------------------------------------------------
C                   DYNAMIC = INTEGRATE
C--------------------------------------------------------------------
      ELSEIF(DYNAMIC.EQ.INTEGR) THEN

          IF(YRDOY.EQ.STGDOY(9)) THEN
C              Emergence
          !added for initialization of Pceres     MA 03jan2014
          WTLF = LFWT * PLTPOP      !Leaf weight, g/m2
          STMWTO = STMWT * PLTPOP   !Stem weight, g/m2
          RTWTO = RTWT * PLTPOP     !Root weight, g/m2

              CALL P_Ceres (EMERG, ISWPHO,                      !Input
     &          CumLeafSenes, DLAYR, DS, FILECC, MDATE, NLAYR,  !Input
     &          PCNVEG, PLTPOP, PODWT, RLV, RTDEP, RTWTO,       !Input
     &          SDWT, SWIDOT, SeedFrac, SPi_AVAIL, Stem2Ear,    !Input
     &          STMWTO, VegFrac, WLIDOT, WRIDOT, WSIDOT,        !Input
     &          WTLF, YRPLT,                                    !Input
     &          SENESCE,                                        !I/O
     &          PConc_Shut, PConc_Root, PConc_Shel, PConc_Seed, !Output
     &          PStres1, PStres2, PUptake, FracRts)             !Output
          ENDIF

      !----------------------------------------------------------
      !   Compute Nitrogen Stress Factors
      !----------------------------------------------------------

      IF (ISWNIT .NE. 'N') THEN
         CALL SG_NFACT(DYNAMIC,
     &       AGEFAC, CNSD1, CNSD2, ISTAGE, NDEF3, NFAC,
     &       NSTRES, RANC, RCNP, TANC, TCNP, TMNC, XSTAGE)
      ELSE
         AGEFAC = 1.0
         NSTRES = 1.0
         NDEF3 = 1.0
         NFAC = 1.0
      ENDIF

      !-------------------------------------------------------------
      !      Compute Water Stress Factors
      ! ------------------------------------------------------------
      SWFAC  = 1.0
      TURFAC = 1.0

      IF(ISWWAT.NE.'N') THEN
         IF (EOP .GT. 0.0) THEN
            EP1 = EOP * 0.1

            IF (TRWUP / EP1 .LT. RWUEP1) THEN
               TURFAC = (1./RWUEP1) * TRWUP / EP1
            ENDIF

            IF (EP1 .GE. TRWUP) THEN
              SWFAC = TRWUP / EP1
            ENDIF

         ENDIF
      ENDIF

      TURFAC = REAL(INT(TURFAC*1000))/1000

      !-------------------------------------------------------------
      !      Compute Water Saturation Factors
      ! ------------------------------------------------------------
      SATFAC = 0.0
      SUMEX = 0.0
      SUMRL = 0.0

      DO L = 1,NLAYR

      !------------------------------------------------------------
      !PORMIN = Minimum pore space required for supplying oxygen to
      !         roots for optimum growth and function
      !TSS(L) = Number of days soil layer L has been saturated
      !         above PORMIN
      !------------------------------------------------------------
          IF ((SAT(L)-SW(L)) .GE. PORMIN) THEN
              TSS(L) = 0.
          ELSE
              TSS(L) = TSS(L) + 1.
          ENDIF

      !------------------------------------------------------------
      ! Delay of 2 days after soil layer is saturated before root
      ! water uptake is affected
      !------------------------------------------------------------

          IF (TSS(L) .GT. 2.) THEN
              SWEXF = (SAT(L)-SW(L))/PORMIN
              SWEXF = MAX(SWEXF,0.0)
          ELSE
              SWEXF = 1.0
          ENDIF

          SWEXF = MIN(SWEXF,1.0)
          SUMEX  = SUMEX + DLAYR(L)*RLV(L)*(1.0 - SWEXF)
          SUMRL  = SUMRL + DLAYR(L)*RLV(L)
      ENDDO

      IF (SUMRL .GT. 0.0) THEN
          SATFAC = SUMEX/SUMRL
      ELSE
          SATFAC = 0.0
      ENDIF

      SATFAC = AMAX1(SATFAC,0.0)
      SATFAC = AMIN1(SATFAC,1.0)

      !-------------------------------------------------------------
      !                Daily Photosynthesis Rate
      !-------------------------------------------------------------

      PAR = SRAD*PARSR        !PAR local variable
      LIFAC =1.5 - 0.768 * ((ROWSPC * 0.01)**2 * PLTPOP)**0.1
      PCO2  = TABEX (CO2Y,CO2X,CO2,10)
      PCARB = RUE * PAR/PLTPOP * (1.0 - EXP(-LIFAC * LAI))
      PCARB = PCARB*PCO2      !chp added

      TEMPM = (TMAX + TMIN)*0.5   !Mean air temperature, C

      TT    = 0.25*TMIN+0.75*TMAX
      PRFT = CURV('LIN',PRFTC(1),PRFTC(2),PRFTC(3),PRFTC(4),TT)
      PRFT  = AMAX1 (PRFT,0.0)
      PRFT = MIN(PRFT,1.0)

C      Saturated soil water content reduces RWU and causes damage
C      through SWFAC. Do not need to also cause reduction through SATFAC
C WDB 10/20/03      CARBO = PCARB*AMIN1 (PRFT,SWFAC,NSTRES,(1-SATFAC))*SLPF

      CARBO = PCARB*AMIN1 (PRFT,SWFAC,NSTRES, PStres1)*SLPF

C-GH  CARBO = PCARB*AMIN1 (PRFT,SWFAC,NSTRES)*SLPF
      !Reduce CARBO for assimilate pest damage
      CARBO = CARBO - ASMDOT
      CARBO = MAX(CARBO,0.0)

      !---------------------------------------------------------------
      !      Compute temperature effect on leaf expansion
      !---------------------------------------------------------------
      TEMF  = 1.0

      DO I = 1, 8
         TMFAC1(I) = 0.931 + 0.114*I-0.0703*I**2+0.0053*I**3
      END DO

      IF (TMIN .LT. 14.0 .OR. TMAX .GT. 32.0) THEN
         IF (TMAX .LT. TBASE) THEN
            TEMF = 0.0
         ENDIF
         IF (TEMF .NE. 0.0) THEN
            TEMF = 0.0
            DO I = 1, 8
               TTMP = TMIN + TMFAC1(I)*(TMAX-TMIN)
               IF (TTMP .GT. 14.0 .AND. TTMP .LE. 32.0) THEN
                   TEMF = TEMF + 1.0/8.0
               ENDIF
               IF (TTMP .GE.  8.0 .AND. TTMP .LT. 14.0) THEN
                   TEMF = TEMF + 0.021*(TTMP-8.0)
               ENDIF
               IF (TTMP .GT. 32.0 .AND. TTMP .LT. 42.0) THEN
                   TEMF = TEMF + 0.0125*(42.0-TTMP)
               ENDIF
            END DO
         ENDIF
      ENDIF

      !--------------------------------------------------------------
      !       Compute leaf characteristics for different stages
      !--------------------------------------------------------------

      DTT = AMAX1 (DTT,0.0)

C-GH	IF ((ISTAGE .GT. 3) .OR.
C-GH  &    (ISTAGE .EQ. 3  .AND. SUMDTT .GT. (PANTH-P3)-3.0*PHINT)) THEN
	IF (ISTAGE .GT. 3) THEN
          GO TO 10
      ENDIF

      PC     = 1.0
      IF (CUMPH .LT. 5.0) THEN
          PC  = 0.66+0.068*CUMPH
      ENDIF

      TI     = DTT/(PHINT*PC)
      CUMPH  = CUMPH+DTT/(PHINT*PC)
      XN     = CUMPH
      LEAFNO = INT(XN)

      IF (ISTAGE .EQ. 3) THEN
         SLW = 0.0055+0.003*(SUMDTT/(PANTH - P3))
      ENDIF

      GCS    = 0.33
      XTN    = -10.34*EXP(-PLAY*CUMPH)
C-MA       A      = 6000.0

      IF (SUMDTT .GE. 120.0 .AND. ISTAGE .LE. 2) THEN
         IF (DTT .LE. 0.0) THEN
            DTT = 1.0
         ENDIF
         SUMRTR = SUMRTR + SRAD * 23.9/DTT
         TDUR   = TDUR   + 1.0
         RTR    = SUMRTR / TDUR
C-GH         IF (RTR .LT. 27) THEN
C-GH            TILN = 1.0
C-GH         ELSE
C        Correct previous statement. Always reset to 1
C        Define tillering, but threshold unclear
C-GH         IF (RTR .GT. 27.0) THEN
            TC1  = 1.0/25.0*(RTR-27.0)
            TC2  = 6.25E-5*(40.0-PLTPOP*TILN)**3
            TILN = TILN+TI*AMIN1(TC1,TC2)*TURFAC
            IF (TILN*PLTPOP .GT. 40.0) THEN
               TILN = 40.0/PLTPOP
            ENDIF
            TILN = AMAX1 (TILN,1.0)
C-GH         ENDIF
          IF (TILFAC .LT. 0.5) THEN
             TILN = 1.0
          ENDIF
      END IF

C--------------------------------------------------------------------
C                     ISTAGE = 1
C--------------------------------------------------------------------

   10 IF (ISTAGE .EQ. 1) THEN
C      Plant leaf area
         PLAN = A*EXP(XTN)
         PLAG = (PLAN-PLAO)*AMIN1(TURFAC,TEMF,PStres2,AGEFAC)

C-GH     PLAG = (PLAN-PLAO)*AMIN1(TURFAC,TEMF,AGEFAC)

         PLAO = PLAN
C-MA add Pstress 2 as for maize ( JULY 2016)
         IF (TILN .GT. 1.0 .AND. CUMPH .GT. 5.0) THEN
            PLATN = (0.79-0.049*(5.0-TILN)**2)*((CUMPH-5.0)**3)*0.5
            PLAGT = (PLATN-PLATO)*AMIN1(TURFAC,TEMF,PStres2,AGEFAC)
            PLATO = PLATN
            PLAG  = PLAG + PLAGT
         END IF

C-MA                PLAG   = GROLF/0.0038
               GROLF  = PLAG  * (1/SLA1)! myriam 7feb2018

         GRORT  = CARBO - GROLF

C-GH      IF (GRORT .LE. 0.25*CARBO) THEN
          IF (GRORT .LE. RTPC * CARBO) THEN
C-GH         GRORT  = CARBO*0.25
             GRORT  = CARBO * RTPC
             SEEDRV = SEEDRV + CARBO - GROLF - GRORT
             IF (SEEDRV .LE. 0.0) THEN
                SEEDRV = 0.0
C-GH            GROLF  = CARBO*0.7500
                GROLF  = CARBO * (1.0 - RTPC)
C-MA                PLAG   = GROLF/0.0038
                 PLAG   = GROLF/(1/SLA1) ! myriam 7feb2018
             ENDIF
         ENDIF

         PLA    = PLA  + PLAG
         LFWT   = LFWT + GROLF
      ENDIF
C--------------------------------------------------------------------
C                      ISTAGE = 2
C--------------------------------------------------------------------
      IF (ISTAGE .EQ. 2) THEN
C      Plant leaf area
C-MA add Pstress 2 as for maize ( JULY 2016)
         PLAN   = A*EXP(XTN)
         PLAG   = (PLAN-PLAO)*AMIN1(TURFAC,TEMF,PStres2,AGEFAC)
         PLAO   = PLAN

         IF (TILN .GT. 1.0) THEN
            PLATN = (0.79-0.049*(5.0-TILN)**2)*((CUMPH-5.0)**3)*0.5
            PLAGT = (PLATN-PLATO)*AMIN1(TURFAC,TEMF,PStres2,AGEFAC)
            PLATO = PLATN
            PLAG  = PLAG + PLAGT
         END IF

         CARBO  = CARBO + SEEDRV
         SEEDRV = 0.0

         GROLF  = PLAG  * (1/SLA2)! myriam 7feb2018
C-ma         GROLF  = PLAG*0.0053
C        GROSTM = GROLF*0.1
         GROSTM = GROLF * STPC
C-GH   Defined STPC and moved to Species file

C-GH     IF (GROLF+GROSTM .GT. CARBO*0.75) THEN
C-GH        GRF    = CARBO*0.75/(GROLF+GROSTM)
C-GH         IF (GROLF+GROSTM .GT. CARBO * (1.0 - RTPC)) THEN
C-GH            GRF    = CARBO * (1.0 - RTPC)/(GROLF+GROSTM)
C-GH            GROLF  = GROLF*GRF
C-GH            GROSTM = GROSTM*GRF
C-GH            PLAG   = GROLF/0.0053
C-GH         END IF

         GRORT  = CARBO - GROLF - GROSTM
         IF (GRORT .LT. CARBO * RTPC) THEN
            GRORT  = CARBO  * RTPC
            IF ((GROLF+GROSTM) .GT. 0.0) THEN
              GRF    = CARBO  * (1.0 - RTPC)/(GROLF+GROSTM)
              GROLF  = GROLF  * GRF
              GROSTM = GROSTM * GRF
            ELSE
              GROLF  = (CARBO - GRORT)/(1.0 + STPC)
              GROSTM = GROLF * STPC
            ENDIF
C-MA            PLAG   = GROLF/0.0053
         PLAG   = GROLF/ (1/SLA2)!MA! myriam 7feb2018

         ELSE IF (GRORT .GE. CARBO * RTPC) THEN
            GRORT  = CARBO  * RTPC
            IF ((GROLF+GROSTM) .GT. 0.0) THEN
              GRF    = CARBO  * (1.0 - RTPC)/(GROLF+GROSTM)
              GROLF  = GROLF  * GRF
              GROSTM = GROSTM * GRF
            ELSE
              GROLF  = (CARBO - GRORT)/(1.0 + STPC)
              GROSTM = GROLF * STPC
            ENDIF
             PLAG   = GROLF/SLA2 ! myriam 7feb2018
C-ma         GROLF  = PLAG*0.0053

         ENDIF

         PLA    = PLA   + PLAG
C-GH     GRORT  = CARBO - GROLF-GROSTM
         LFWT   = LFWT  + GROLF
         STMWT  = STMWT + GROSTM
      ENDIF
C--------------------------------------------------------------------
C                     ISTAGE = 3
C--------------------------------------------------------------------
      IF (ISTAGE .EQ. 3) THEN
C      Plant leaf area
C-MA add Pstress 2 as for maize ( JULY 2016)
         PLAN  = A*EXP(XTN)
         PLAG  = (PLAN-PLAO)*AMIN1(TURFAC,TEMF,PStres2,AGEFAC)
         PLAO  = PLAN
C      Tiller Growth
         TLG   = PHINT*5.0

         IF (SUMDTT .GE. (PANTH - P3) - TLG) THEN
            PLAG = PLAG*(0.7+0.2*(((PANTH - P3)-SUMDTT)/TLG)**2)
         ENDIF

         IF (TILN .GT. 1.0) THEN
            PLATN = (0.79-0.049*(5.0-TILN)**2)*((CUMPH-5.0)**3)*0.5
            PLAGT = (PLATN-PLATO)*AMIN1(TURFAC,TEMF,PStres2,AGEFAC)
            PLATO = PLATN
            PLAG  = PLAG + PLAGT
            PLAG  = AMAX1 (PLAG,0.0)
C
C            Allow PLAG to decline if tiller dies I.E. PLAGT < 0
C
         ENDIF

C-MA         GROLF = PLAG*0.0078
          GROLF = PLAG*(1/SLA3) !sla = 250cm2.g-1

         FLG   = 5.0*PHINT

C-GH     IF (SUMDTT .LE. P3-FLG) THEN
         IF (SUMDTT .LE. (PANTH-P3) - FLG) THEN
C          GROSTM = GROLF*(0.1+0.8*(SUMDTT/P3)**2)
           GROSTM = GROLF*(STPC + 0.8*(SUMDTT/(PANTH-P3))**2)
C-GH   Defined STPC and moved to Species file
         ELSE

C	                 KSTM=0.00008827*(CUMDTT-GDD2)
C JOSE UF: OBTAINED REGRESSION FOR STEM GROWTH RATE CHANGE OVER TIME BASED ON FIELD MEASUREMTNS (12-13)
C                     GROSTM = KSTM*DTT*TILN*AMIN1(TURFAC,TEMF)
                GROSTM = 0.048*DTT*TILN*AMIN1(TURFAC,PStres2,TEMF)
     &                *49.0/PHINT
         ENDIF

         TDUR  = TDUR + 1.0
         GRORT  = CARBO - GROLF - GROSTM

C-GH     IF (GRORT .LT. CARBO*0.25) THEN
C-GH        GRORT  = CARBO  * 0.25
C-GH        GRF    = CARBO  * 0.75/(GROLF+GROSTM)
         IF (GRORT .LT. CARBO * RTPC) THEN
            GRORT  = CARBO  * RTPC
            IF ((GROLF+GROSTM) .GT. 0.0) THEN
              GRF    = CARBO  * (1.0 - RTPC)/(GROLF+GROSTM)
              GROLF  = GROLF  * GRF
              GROSTM = GROSTM * GRF
            ELSE
              GROLF  = (CARBO - GRORT)/(1.0 + STPC)
              GROSTM = GROLF * STPC
            ENDIF
c-MA            PLAG   = GROLF  / 0.0078
           PLAG   = GROLF  / (1/SLA3)

            SUMRTR = SUMRTR + GRF
            TCON   = SUMRTR / TDUR
         ELSE IF (GRORT .GE. CARBO * RTPC) THEN
            GRORT  = CARBO  * RTPC
            IF ((GROLF+GROSTM) .GT. 0.0) THEN
              GRF    = CARBO  * (1.0 - RTPC)/(GROLF+GROSTM)
              GROLF  = GROLF  * GRF
              GROSTM = GROSTM * GRF
            ELSE
              GROLF  = (CARBO - GRORT)/(1.0 + STPC)
              GROSTM = GROLF * STPC
            ENDIF
            PLAG   = GROLF  / 0.0078
            SUMRTR = SUMRTR + 1.0
            TCON   = SUMRTR / TDUR
         ENDIF

         IF (TILFAC .GT. 0.5) THEN
           TILN  = TILN*(0.4+0.6*TCON)
           TILN  = AMAX1 (TILN,1.0)
         ENDIF
         LFWT   = LFWT  + GROLF
         STMWT  = STMWT + GROSTM
         PLA   = PLA   + PLAG
C-GH     SLAN  = 1.0+200.0*(SUMDTT/P3)**2
         SLAN  = 1.0+200.0*(SUMDTT/(PANTH - P3))**2
      ENDIF
C--------------------------------------------------------------------
C                    ISTAGE = 4
C--------------------------------------------------------------------
      IF (ISTAGE .EQ. 4) THEN

C      	KSTM=0.00008827*(CUMDTT-GDD2)
C JOSE UF: OBTAINED REGRESSION FOR STEM GROWTH RATE CHANGE OVER TIME BASED ON FIELD MEASUREMTNS (2012-2013)
C        GROSTM = KSTM*DTT*(1.0+(TILN-1.0)*TSIZE)*AMIN1(TURFAC,TEMF)

C-MA add Pstress 2 as for maize ( JULY 2016)
      GROSTM =0.07*DTT*(1.0+(TILN-1.0)*TSIZE)*AMIN1(TURFAC,PStres2,TEMF)
     &             *49.0/PHINT
C
C         GROSTM coeff changed from 0.07 to 0.10
C         TSIZE is relative size of tillers compared to main culm.
C         TSIZE is a function of PLTPOP
C
C-GH     GRORT  = CARBO - GROSTM
C-GH Check for negative "new" root growth
C-GH
         IF (CARBO .GT. GROSTM) THEN
             GRORT  = CARBO - GROSTM
         ELSE
             GRORT = 0.0
             GROSTM = CARBO
         ENDIF

         GROLF  = 0.0

c-MA     IF (GRORT .LT. 0.08*CARBO) THEN
c-MA        GRORT =CARBO *0.08
c-MA        GROSTM = CARBO*0.92
c-MA     ENDIF

c MA 4dec2014
c change to fix the root biomass partitioning during stage 4
c verification done in the standard dssat shell x file + the x file for sorghum in west Africa
c generally this change improved the simulation in term of grain yield and above ground biomass

         IF (GRORT .GT. 0.08*CARBO) THEN
            GRORT = CARBO *0.08
            GROSTM = CARBO*0.92
         ENDIF

C-GH     GGG    = (CUMDTT-P1-100.0-P3)/(P4+P5)
C-GH     GGG    = (CUMDTT-P1-100.0-(PANTH-P3))/(PFLOWR + P5)
         GGG    = CUMP4/(PFLOWR + P5)
	   SLAN   = PLA*(0.07+GCS*GGG)
         STMWT  = STMWT + GROSTM
      ENDIF
C--------------------------------------------------------------------
C                      ISTAGE = 5
C--------------------------------------------------------------------
      IF (ISTAGE .EQ. 5) THEN
         IF (PLTPOP .EQ. 0.01) RETURN

         IF (CARBO .EQ. 0.0 .AND. SUMDTT .LT. P5) THEN
            SUMDTT = P5
            WRITE(MESSAGE(1),100)
            CALL WARNING(1,ERRKEY, MESSAGE)             !
 100        FORMAT('Crop matured early due to extreme stress')
         ENDIF

         CARBO  = CARBO*(1.0-0.35*(SUMDTT/P5))

C-GH     SLAN   = PLA*(0.07+GCS*(CUMDTT-P1-100.0-P3)/(P3 + P4 + P5))
C-GH     SLAN   = PLA*(0.07+GCS*(CUMDTT-P1-100.0-(PANTH - P3))/
C-GH &            (PFLOWR + P4 + P5))
         GGG    = CUMP4/(PFLOWR + P5)
         SLAN   = PLA*(0.07+GCS*GGG)

         RGFILL = 1.0
         RGFILL = CURV('LIN',RGFIL(1),RGFIL(2),RGFIL(3),
     &                     RGFIL(4),TEMPM)
         RGFILL = AMAX1 (RGFILL,0.0)
         RGFILL = MIN(RGFILL,1.0)
         PAF    = 1.0
         PAF    = 1.0-(SUMDTT/P5)*0.85
C
C         IF (SUMDTT .GT. 0.75*P5) PAF = 1.0 - (SUMDTT-P5*0.75)*2.5/P5
C
         WSTR   = 1.0
         FSTR   = 1.0

         IF (ISWWAT .EQ. 'Y') THEN
            WSTR = 1.0 - CSD2 /ICSDUR
         ENDIF

         IF (ISWNIT .EQ. 'Y') THEN
            FSTR = 1.0 - CNSD2/ICSDUR
         ENDIF

         GROPAN = RGFILL*PGC*PAF*(1.0+(TILN-1.)*TSIZE)*AMIN1(FSTR,WSTR)
         GRORT  = 0.0
         GROSTM = CARBO - GROPAN

         IF ((STMWT+GROSTM) .GE. SWMIN) THEN
            IF (GROSTM .GT. 0.0) THEN
               GRORT = GROSTM*0.5
               STMWT = STMWT + GROSTM*0.5
            ELSE
               STMWT = STMWT + GROSTM
            ENDIF
         ELSE
            IF (LFWT .GT. LWMIN) THEN
               STMWT = STMWT+LFWT*0.0050
               LFWT  = LFWT*0.9950
               IF (STMWT+GROSTM .LT. SWMIN) THEN
                  GROPAN = CARBO + (STMWT-SWMIN)
                  STMWT  = SWMIN
               ENDIF
            ELSE
               GROPAN = CARBO + (STMWT-SWMIN)
               STMWT  = SWMIN
            ENDIF
         ENDIF

         IF (ISWNIT .NE. 'N') THEN
C            Code inserted from wheat model
            RGNFIL = 4.82966-3.2488*DTT+0.2503*(TMAX-TMIN)+4.3067*TEMPM
            RGNFIL = RGNFIL*0.28
C           Adjusted from wheat model to sorghum grain size
            NSINK  = RGNFIL*GPP*1.E-6
            NSINK  = NSINK*NDEF3

            IF (NSINK .NE. 0.0) THEN
               RMNC   = RCNP*0.75
               TANC   = STOVN/STOVWT
               NPOOL1 = STOVWT*(TANC-TMNC)
               NPOOL2 = RTWT*(RANC-RMNC)
               NPOOL2 = AMAX1 (NPOOL2,0.0)
               NPOOL1 = AMAX1 (NPOOL1,0.0)
               XNF    = AMIN1((0.18+0.2*NFAC),0.30)
               TNLAB  = XNF*NPOOL1
               RNLAB  = XNF*NPOOL2
               NPOOL  = TNLAB+RNLAB

               NSDR   = NPOOL/NSINK
               IF (NSDR .LT. 1.0) THEN
                  NSINK  = NSINK *NSDR
                  GROPAN = GROPAN*NSDR
               ENDIF

               IF (NSINK .GT. TNLAB) THEN
                  IF (TNLAB .GT. STOVWT*TMNC) THEN
                     TNLAB = STOVWT*TMNC
                  ENDIF
                  STOVN = STOVN - TNLAB
                  RNOUT = NSINK - TNLAB
                  TNLAB = 0.0
                  IF (RNOUT .GT. RTWT*RMNC) THEN
                     RNOUT = RTWT*RMNC
                  ENDIF
                  ROOTN = ROOTN - RNOUT
                  RANC  = ROOTN / RTWT
                      ELSE
                  STOVN = STOVN - NSINK
               ENDIF
            ENDIF

            GRAINN = GRAINN + NSINK
            TANC   = STOVN  / STOVWT
         ENDIF

         IF (STMWT .GT. SWMAX) THEN
            GROPAN = GROPAN + (STMWT-SWMAX)*0.8
            GRORT  = GRORT  + (STMWT-SWMAX)*0.2
            STMWT  = SWMAX
         ENDIF

         GROSTM = AMAX1 (GROSTM,0.0)
         PANWT  = PANWT + GROPAN
      ENDIF

C--------------------------------------------------------------------
C                          ISTAGE = 6
C--------------------------------------------------------------------
      IF (ISTAGE .EQ. 6) THEN
         RETURN
      ENDIF

C--------------------------------------------------------------------
C  The following code is executed each day regardless of growth stage
C--------------------------------------------------------------------
      IF (CARBO .EQ. 0.0)  THEN
         CARBO = 0.001
      ENDIF

      PDWI   = PCARB*(1.0-GRORT/CARBO)
      PGRORT = PCARB*GRORT/CARBO

C------------------------------------------------------------
C  Compute Leaf Senescence Factors
C------------------------------------------------------------

!     Senescence due to water
      SLFW   = (1-FSLFW) + FSLFW*SWFAC

!     Senescence due to nitrogen
      SLFN   = (1-FSLFN) + FSLFN*NSTRES

!     Senescence due to phosphorus stress
!     5/9/07 CHP, JIL, KJB change from PStres2 to PStres1
      SLFP   = (1-FSLFP) + FSLFP * PSTRES1

!     Senescence due to light competition
      SLFC   = 1.00
      IF (LAI .GT. 4.0) THEN
         SLFC = 1.0-0.008*(LAI-4.0)
      ENDIF

      ! Senescence due to temperature
      SLFT   = 1.0
      IF (TEMPM .LE. 6.0) THEN
         SLFT   = 1.0-(6.0-TEMPM)/6.0
      ENDIF

      IF (TMIN .LE. 0.0) THEN
         SLFT = 0.0
      ENDIF
      SLFT   = AMAX1 (SLFT,0.0)

C--------------------------------------------------------------
C  APPLY PEST DAMAGE
C--------------------------------------------------------------

      IF(ISWDIS.EQ.'Y') THEN
!        Leaf Damage
          IF((LFWT+STMWT).GT.0.0)
     $      STOVN=STOVN - STOVN*(WLIDOT/PLTPOP)/(LFWT+STMWT)
          IF (PLTPOP.GT.0.0.AND.LFWT.GT.0.0)
     &      LAIDOT = WLIDOT*(PLA-SENLA)/(LFWT*PLTPOP)  !cm2/plant/day
          IF(PLTPOP.GT.0.0)
     &      LFWT = LFWT - WLIDOT/PLTPOP

          PLA = PLA - LAIDOT
          LAI = LAI - LAIDOT*PLTPOP/10000

      ! Stem Damage
          IF(PLTPOP.GT.0.0)
     &       STMWT = STMWT - WSIDOT/PLTPOP
          IF(PLTPOP.GT.0.0.AND.(LFWT+STMWT).GT.0.0)
     &       STOVN=STOVN - STOVN*(WSIDOT/PLTPOP)/(LFWT+STMWT)

      ! Root Weight
          IF(PLTPOP.GT.0.0) THEN
            ROOTN = ROOTN - ROOTN*(WRIDOT/PLTPOP)/RTWT
            RTWT = RTWT - WRIDOT/PLTPOP
          ENDIF

      ! Grain Weight and Number
          IF (PANWT .GT. 0.AND.PLTPOP.GT.0) THEN
            GPP = GPP - GPP*(SWIDOT/PLTPOP)/PANWT
            GRAINN = GRAINN - GRAINN*(SWIDOT/PLTPOP)/PANWT
          ENDIF

          IF(PLTPOP.GT.0.0) THEN
            PANWT = PANWT - SWIDOT/PLTPOP
C           EARWT = EARWT - SWIDOT/PLTPOP
          ENDIF

      ! Population
          IF(PPLTD.GT.0) THEN
             PLTPOP = PLTPOP - PLTPOP * PPLTD/100
C            EARS = EARS - EARS*PPLTD/100
             LAI = LAI - LAI*(PPLTD/100)
           ENDIF
      ENDIF

C--------------------------------------------------------------
C    Update State Variables
C--------------------------------------------------------------
      PLAS   = (PLA-SENLA)*(1.0-AMIN1(SLFW,SLFC,SLFT,SLFN,SLFP))
      SENLA  = SENLA + PLAS
      SENLA  = AMAX1 (SENLA,SLAN)
      SENLA  = AMIN1 (SENLA, PLA)
      LAI    = (PLA-SENLA)*PLTPOP*0.0001

!     Specific leaf area (cm2/g)
      IF (LFWT .GT. 0.) THEN
        SLA = LAI*10000/LFWT
      ELSE
        SLA = 0
      ENDIF

      RTWT   = RTWT  + 0.5*GRORT-0.005*RTWT
      BIOMAS = (LFWT+STMWT+PANWT)*PLTPOP
      DM     = BIOMAS*10.0
      STOVWT = LFWT  + STMWT
      PTF    = (LFWT+STMWT+PANWT) / (RTWT+LFWT+STMWT+PANWT)

C     Note: senesced leaf area (SENLA) is subtracted from leaf area
C           but is not subtracted from leaf weight in CERES v3.5.
C           the following code needs to be turned on to correct this.
C      LFWT = LFWT - (SENLA/PLA)*LFWT

C--------------------------------------------------------------
C       Compute Nitrogen Uptake (and phosphorus? MA 19dec20113)
C--------------------------------------------------------------

      IF (ISWNIT .NE. 'N') THEN
        CALL SG_NUPTAK(
     %    RANC, ROOTN,RTWT,TANC,STOVN,STOVWT,TRNU,NLAYR,
     %    RLV,NO3,NH4,PDWI,TCNP,UNO3,UNH4,
     %    XSTAGE,RCNP,PGRORT,PLTPOP,SW,LL,SAT,DLAYR,
     %    SHF,PTF, SENESCE, KG2PPM, PLIGRT)
      ENDIF

        IF (ISWPHO .NE. 'N') THEN
          CALL P_Ceres (DYNAMIC, ISWPHO,                    !Input
     &      CumLeafSenes, DLAYR, DS, FILECC, MDATE, NLAYR,  !Input
     &      PCNVEG, PLTPOP, PODWT, RLV, RTDEP, RTWTO,       !Input
     &      SDWT, SWIDOT, SeedFrac, SPi_AVAIL, Stem2Ear,    !Input
     &      STMWTO, VegFrac, WLIDOT, WRIDOT, WSIDOT,        !Input
     &      WTLF, YRPLT,                                    !Input
     &      SENESCE,                                        !I/O
     &      PConc_Shut, PConc_Root, PConc_Shel, PConc_Seed, !Output
     &      PStres1, PStres2, PUptake, FracRts)             !Output
        ENDIF
C--------------------------------------------------------------------
C                   DYNAMIC = OUTPUT
C--------------------------------------------------------------------
      ELSEIF(DYNAMIC.EQ.OUTPUT) THEN
	  IF (ISWPHO .NE. 'N') THEN
          CALL P_Ceres (DYNAMIC, ISWPHO,                    !Input
     &      CumLeafSenes, DLAYR, DS, FILECC, MDATE, NLAYR,  !Input
     &      PCNVEG, PLTPOP, PODWT, RLV, RTDEP, RTWTO,       !Input
     &      SDWT, SWIDOT, SeedFrac, SPi_AVAIL, Stem2Ear,    !Input
     &      STMWTO, VegFrac, WLIDOT, WRIDOT, WSIDOT,        !Input
     &      WTLF, YRPLT,                                    !Input
     &      SENESCE,                                        !I/O
     &      PConc_Shut, PConc_Root, PConc_Shel, PConc_Seed, !Output
     &      PStres1, PStres2, PUptake, FracRts)             !Output
        ENDIF

C--------------------------------------------------------------------
C                   DYNAMIC = SEASEND
C--------------------------------------------------------------------
      ELSEIF(DYNAMIC.EQ.SEASEND) THEN

	  IF (ISWPHO .NE. 'N') THEN
          CALL P_Ceres (DYNAMIC, ISWPHO,                    !Input
     &      CumLeafSenes, DLAYR, DS, FILECC, MDATE, NLAYR,  !Input
     &      PCNVEG, PLTPOP, PODWT, RLV, RTDEP, RTWTO,       !Input
     &      SDWT, SWIDOT, SeedFrac, SPi_AVAIL, Stem2Ear,    !Input
     &      STMWTO, VegFrac, WLIDOT, WRIDOT, WSIDOT,        !Input
     &      WTLF, YRPLT,                                    !Input
     &      SENESCE,                                        !I/O
     &      PConc_Shut, PConc_Root, PConc_Shel, PConc_Seed, !Output
     &      PStres1, PStres2, PUptake, FracRts)             !Output
        ENDIF

C--------------------------------------------------------------------
C     END OF DYNAMIC IF-BLOCK
C--------------------------------------------------------------------
      ENDIF

      RETURN
      END SUBROUTINE SG_GROSUB

C--------------------------------------------------------------------
C                         DEFINITIONS
C--------------------------------------------------------------------
C
C  NSINK  : Demand for N associated with grain filling (g/plant/day)
C  NPOOL  : Total plant N available for translocation to grain (g/plant)
C  NPOOL1 : Tops N available for translocation to grain (g/plant)
C  NPOOL2 : Root N available for translocation to grain (g/plant)
C  NSDR   : Plant N supply/demand ratio used to modify grain N content
C  I      : Loop counter
C  PAR    : Daily photosynthetically active radiation, calculated as half
C           the solar radiation - MJ/square metre
C  TT     :
C  PCARB  : Daily amount of carbon fixed - g
C  PRFT   : Photosynthetic reduction factor for low and high temperatures
C  TTMP   : c-MA  11dec2014 i think create to reduce leaf growth due to temp effect, but not yet implemented
C  PC     : c-MA 11dec2014 factor used to reduce leaf growth under 5 fully expended leaves.
C  TI     : Fraction of a phyllochron interval which occurred as a fraction
C           of today's daily thermal time
C  XTN    :  C-MA 11dec2014 Exponent factor from equation 2 p35 in ceres sorghum documentation, depend on PLAY( corresponding to K in eq.2, which dependent on G1,)
C  A      : Zero to unity factor for relative nitrification rate (unitless) c-ma it's actually the A from eq.2 which represents max leaf area ar infinite time
C  RTR    :
C  TC1    :
C  TC2    :
C  PLATN  :
C  PLAGT  :
C  GRF    :
C  TLG    :
C  FLG    :
C  GGG    :
C  RGFILL : Rate of grain fill - mg/day
C  WSTR   :
C  FSTR   :
C  GROPAN : Daily growth of the pannicle - g
C  RGNFIL :
C  RMNC   : Root minimum nitrogen concentration (g N/g root dry weight)
C  XNF    :
C  TNLAB  :
C  RNLAB  :
C  RNOUT  :
C  SLFW   :
C  SLFN   :
C  SLFC   :
C  SLFT   :
C  PLAS   : The rate of senescence of leaf area on one plant - sq. cm/day
C=======================================================================
!PAR - photosynthetically active radiation, MJ/m2/d
!PARSR - conversion from solar radiation to PAR
!LIFAC - light interception factor used to reduce photosynthesis under
!        wide rowspacing or low population (0-1.0)
!RUE - radiation use efficiency (from ecotype file), g CH2O/MJ PAR
!PCARB       !Potential dry matter production under optimum water, nitrogen and temperature, g/plant
!ROWSPC - Row spacing, cm
!LAI - leaf area index, m2 leaf/m2 ground
!ASMDOT - daily assimilate damage due to pests, g/plant/day
!CARBO - daily plant growth rate, g/plant/day
!TEMPM - average daily temperature, C
!TT - weighted average daily temperature for computing temperatue effect on photosynthesis
!


      SUBROUTINE despikex( buf, lbuf, ibuf, scr, lscr, iscr, nready )
c*******
C*******      MAKE SURE TO USE THE RIGHT COMMON BLOCK NAME
c*******      despike and tredit
c
c  ARGUMENTS:
c  buf   - The trace, with SEGY header as TYPE REAL
c  lbuf  - The trace, with SEGY header as TYPE INTEGER*4
c  ibuf  - The trace, with SEGY header as TYPE INTEGER*2
c
c  COPYRIGHT (C) The Regents of the University of California
c  ALL RIGHTS RESERVED.
c  Written by Paul Henkart, SIO, August 1992
c
c  Mod 14 June 1994 - Add type and type 2 (Trehu/Sutton)
c  Mod 18 Aug 95 by Mike Holzrichter, ODP and pch - Add quart, remove type
c  Mod 1 Apr 96 - Threshold won't work when thres(1) + thres(2) = 0
c  Mod 22 July 97 - Add KILL, ALPHA, SET, ADDWB, VEL, SES, SEL
c  Mod 2 Apr 98 - Add MEDIAN
c  Mod 28 May 98 - Several things for median stack
c  Mod 1 Apr 99 - Add MINVAL/VALMIN
c  Mod 9 Sept 00 - SES/SEL was going to Trehu
c  Mod 11 Sept 00 - Add LIMITS, IHDR, LHDR, IHDR
c  Mod ????? - increase iapsiz = 5000000
c  Mod 11 Sept 01 - Make sure SES and SEL don't get too small
c                   when ADDWB is used.
c  Mod 15 Feb 02 - Add WINLEN and HCYCLE
c  Mod 15 Jul 02 - SES/SEL had bad sel end time check
c  Mod 11 Oct 02 - DESPIKE didn't work at ALL due to bad common name.
c                  Was   COMMON /despik/ instead of /despike/
c  Mod 24 Aug 05 - Add TAILMUTE
c  Mod 9 Apr 09 - Use numdat as well as unsigned int for number of samples.
c  Mod 13 Oct 09 - Add offline bandpass filtering
c  Mod 2 Dec 09 - thres & kill didn't work
c  Mod 17 May 10 - Stop using real mute times in header words 47 & 48
c  Mod 18 Jul 10 - Replace NaN with 0.
c  Mod 1 Aug 12 - Add valmax, mintype, maxtype, devpct
c  Mod 24 Mar 15 - Mix up for fno/lno and shots vs rp.
c
c
      PARAMETER (iapsiz = 5000000)
      REAL    APDATA(0:iapsiz)
      INTEGER*2 IAPDATA(0:iapsiz)
      INTEGER LAPDATA(0:iapsiz)
      COMMON /apmem/ apdata
      EQUIVALENCE (APDATA,IAPDATA)
      PARAMETER (NPTS = 55)
      DIMENSION buf(111), lbuf(111), ibuf(111), scr(111),
     &          lscr(111), iscr(111)
      INTEGER*2 ibuf, iscr
c*******
C*******      MAKE SURE TO USE THE RIGHT COMMON BLOCK NAME
c*******      despike and tredit
      COMMON /despike/ thres(2), lprint, fno, lno, ftr, ltr, type, fac,
     &       quart, kill, alpha, set(4), addwb, vel, ses(2), sel(2),
     &       lunmed, valmin, limits(2), ihdr, lhdr, hdr, winlen, hcycle,
     &       tailmute, pass(2), valmax, mintype, maxtype, devpct

      REAL limits
      INTEGER fno, lno, ftr, ltr, type, kill, addwb
      DIMENSION filpts(NPTS),ldummy(2)
      COMMON /readt/ itunit, numhdr, numdat, ihunit, ireeln, jntrcs,
     *               ifmt, nskip, secs, lrenum, isrcf, idtype,
     *               nfskip, jform, itxsi, itxdel, nfktrc, norigtr
      COMMON /sioap/ iasgnd, irelse, in, iout, nextad, lapsiz, ifree,
     *               iuseap
      COMMON /segyptr/ llsegptr, lrseqptr, lshotptr, lshtrptr, lrpnptr,
     *                 lrptrptr, itridptr, ldisptr,  lwbdptr,  lsxcoptr,
     *                 lrxcoptr, idelmptr, istmptr,  iendmptr, isampptr,
     *                 isiptr,   iyrptr,   idayptr,  ihrptr,   iminptr,
     *                 isecptr,  igmtptr,  ldelsptr,  lsmusptr,lemusptr,
     *                 lsisptr,  lwbtsptr, lgatptr,  lssmsptr, lesmsptr,
     *                 lsbptr,   ifoldptr, icvleptr, lespnptr
      SAVE
      DATA iaddr/0/, ntraces/0/, msamps/100000/, last/0/, mindel/100000/
      DATA iwarn1/0/, nfilpts/0/
c
c
      IF( IAND(lprint,2) .NE. 0 ) THEN
          PRINT *,' thres=',thres,' fno=',fno,' lno=',lno,' ftr=',ftr,
     &     ' ltr=',ltr,' type=',type,' fac=',fac,' quart=',quart
          PRINT *,' kill=',kill,' alpha=',alpha,' set=',set
          PRINT *,' ses=',ses,' sel=',sel,' vel=',vel,' addwb=',addwb
          PRINT *,' limits=',limits,' ihdr=',ihdr,' lhdr=',lhdr,
     &            ' hdr=',hdr,' winlen=',winlen,' hcycle=',hcycle
          PRINT *,' endmute=',endmute,' pass=',pass,' valmax=',valmax,
     &         ' mintype=',mintype,' maxtype=',maxtype,' devpct=',devpct
      ENDIF
      nready = 1

      IF( ibuf(itridptr) .EQ. 2 .AND. lbuf(51) .NE. -1 ) RETURN         ! forget dead traces
      IF( lbuf(lrptrptr) .NE. 0 ) THEN
          lnum = lbuf(lrpnptr)
          ltrno = lbuf(lrptrptr)
      ELSE
          lnum = lbuf(lshotptr)
          ltrno = lbuf(lshtrptr)
      ENDIF
      IF( lnum .LT. fno .OR. lnum .GT. lno ) RETURN
      IF( ltrno .LT. ftr .OR. ltrno .GT. ltr ) RETURN
c      nsamps = ibuf(isampptr)
      nsamps = numdat
      delay = buf(ldelsptr)
      idelay = NINT(delay / buf(lsisptr)) + 1
      si = buf(49)
c****
c****  Put all the data into apdata(nextad) then filter it if requested
c****
c**** force use of the "ap" so it's memory gets allocated and copied to apdata(nextad)
      CALL inap( buf(numhdr+1), numdat )
c**** get the data out of the ap into scr array apdata(nextad)
      iout = 0
      CALL rlseap( apdata(nextad), numdat )
c****  Well, rlseap set in to 0, so CALL rlseap( buf(numhdr+1), numdat )
c**** won't make a copy into buf, which median assumes.  Copy it explicitly.
      DO i = 1, numdat
         buf(numhdr+i) = apdata(nextad+i-1)
      ENDDO
c****
c****  Check for NaN, which also checks as zero.
c****
      DO i = 1, numdat
         IF( buf(numhdr+i) .EQ. 0 )  buf(numhdr+i) = 0.
      ENDDO
c****
c****  Do MEDIAN first because it's so unlike the rest because it needs
c****  a bunch of traces before it can do any work.
c****
      IF( lunmed .NE. 0 ) THEN
c**** Store all of the gather on disc until the end-of-gather flag.
          nwrds = nsamps + numhdr
          CALL wrdisc( lunmed, buf(1), nwrds )
          iaddr = iaddr + nwrds
          ntraces = ntraces + 1
          msamps = MIN( msamps, nsamps )
          mindel = MIN( mindel, idelay )
          last = MAX( last, idelay+nsamps )
          IF( lbuf(51) .NE. -1 ) THEN
              nready = 0
              RETURN
          ENDIF
          iaddr = 0
          CALL podisc( lunmed, 0, 0 )
          index = 1
          nosamps = last - mindel
          IF( nosamps*ntraces .GT. iapsiz ) THEN
              PRINT *,' ***  ERROR  ***  Not enough memory for MEDIAN.'
              PRINT *,' Decrease the record length.'
              PRINT *,' Make sure there is an end-of-gather flag.'
              STOP
          ENDIF
c****     Now put all of the traces in memory so they all start at the
c****     same delay and have the same length.
          DO i = 1, ntraces
             CALL rddisc( lunmed, scr, numhdr, istat)
c             nsamps = iscr(isampptr)
             CALL ushort2long( iscr(isampptr), nsamps )
             delay = scr(ldelsptr)
             idelay = NINT(delay / scr(lsisptr)) + 1
             IF( idelay .GT. mindel ) THEN
                 DO j = mindel, idelay
                    lapdata(index) = -1
                    index = index + 1
                 ENDDO
             ENDIF
             CALL rddisc( lunmed, apdata(index), nsamps, istat)
c****        fill/pad the ends with -1 if too short or muted and we'll
c****        exclude them later.
c             IF( scr(lemusptr) .NE. 0 ) THEN                            ! end mute time in seconds
c                 n = (scr(lemusptr)-delay) / scr(lsisptr) + 1
             IF( iscr(iendmptr) .NE. 0 ) THEN
                 n=(FLOAT(iscr(iendmptr))/1000.-delay)/scr(lsisptr)+1
                 DO j = 0, n-1
                    lapdata(index+j) = -1
                 ENDDO
             ENDIF
             index = index + nsamps
             n = nosamps - (idelay - mindel + nsamps)
             IF( n .GT. 0 ) THEN
                 DO j = 0, n-1
                    lapdata(index+j) = -1
                 ENDDO
                 index = index + n
             ENDIF
          ENDDO
          DO i = 1, nosamps
             n = 0
             jndex = i
             DO j = 1, ntraces
                IF( lapdata(jndex) .NE. -1 ) THEN
                    n = n + 1
                    scr(n) = apdata(jndex)
                ENDIF
                jndex = jndex + nosamps
             ENDDO
             IF( n .LE. 1 ) THEN
                 IF( n .EQ. 0 ) buf(numhdr+i) = 0.
                 IF( n .EQ. 1 ) buf(numhdr+i) = scr(1)
             ELSE
                 CALL sort( n, scr )
                 n2 = n / 2
                 IF( 2*n2 .EQ. n ) THEN
                     buf(numhdr+i) = .5 * (scr(n2)+scr(n2+1))
                 ELSE
                     buf(numhdr+i) = scr(n2+1)
                 ENDIF
             ENDIF
          ENDDO
          IF( lbuf(lrptrptr) .NE. 0 ) THEN
              lbuf(lrptrptr) = 1
          ELSE
              lbuf(lshtrptr) = 1
          ENDIF
          ibuf(isampptr) = nosamps
          CALL long2ushort( nosamps, ibuf(isampptr) )
          numdat = nosamps
          index = 1
          msamps = 100000
          ntraces = 0
          last = 0
          mindel = 100000
          CALL podisc( lunmed, 0, 0 )
          nready = 1
          RETURN
      ENDIF
c****
c****   Do all the work from scr rather than buf so we can do the
c**** detection on the trace that has been scaled.  But the interpolation
c**** or kill is done in buf.  i.e. Don't clobber the trace!
c****
      DO i = 1, nsamps
         scr(i) = buf(numhdr+i)
      ENDDO
      IF( alpha .NE. 0.) THEN
          DO i = 1, nsamps
             scr(i) = scr(i) ** alpha
          ENDDO
      ENDIF
c****
c****
      IF( set(2) .EQ. 0. ) THEN
          is = 1
          ie = nsamps
      ELSE
          time1 = set(1)
          time2 = set(2)
          time3 = set(3)
          time4 = set(4)
          IF( addwb .NE. 0 ) THEN
              time1 = time1 + buf(lwbtsptr)
              time2 = time2 + buf(lwbtsptr)
              time3 = time3 + buf(lwbtsptr)
              time4 = time4 + buf(lwbtsptr)
          ENDIF
          IF( vel .NE. 0 ) THEN
              range = FLOAT(lbuf(ldisptr))
              time1 = SQRT(time1*time1 + (range*range)/(vel*vel))
              time2 = SQRT(time2*time2 + (range*range)/(vel*vel))
              time3 = SQRT(time3*time3 + (range*range)/(vel*vel))
              time4 = SQRT(time4*time4 + (range*range)/(vel*vel))
          ENDIF
          is = NINT((time1-delay) / buf(lsisptr)) + 1
          ie = NINT((time2-delay) / buf(lsisptr)) + 1
          is2 = NINT((time3-delay) / buf(lsisptr)) + 1
          ie2 = NINT((time4-delay) / buf(lsisptr)) + 1
          IF( is .LT. 1 ) is = 1
          IF( ie .GT. nsamps ) ie = nsamps
          IF( is2 .LT. 1 ) is2 = 1
          IF( ie2 .GT. nsamps ) ie2 = nsamps
      ENDIF
c****
c****   type 1 - remove a spike if it exceeds a threshold
c****
      IF( thres(1) .NE. 0. .AND. thres(2) .NE. 0. ) THEN
          IF( IAND(lprint,2) .NE. 0 ) PRINT *,' Type 1 - Threshold'
   10     CONTINUE
          DO 100 istart = is, ie
             IF( scr(istart) .LT. thres(1) .OR.
     &           scr(istart) .GT. thres(2) ) THEN
                 IF( tailmute .NE. 0. ) THEN
c****            zero from the beginning of the spike to the end
                     iadd = tailmute / buf(49)
                     jstart = istart + iadd
                     IF( IAND(lprint,8) .NE. 0 ) PRINT *,
     &                   ' zeroing from sample ',jstart,' to the end.'
                     DO i = jstart, nsamps
                        buf(numhdr+i) = 0.
                     ENDDO
                     RETURN
                 ENDIF
c****            If outside the 2 thresholds, find the next one between
c****            the two thresholds.
                 DO 20 j = istart + 1, ie
                    IF( scr(j) .GE. thres(1) .AND.
     &                  scr(j) .LE. thres(2) ) THEN
                        iend = j - 1
                        GOTO 110
                    ENDIF
   20            CONTINUE
c****            Nothing in the rest of the window lies between thresholds
c****            here if bad to the end of the trace.  Zero it.
                 DO 50 j = istart, nsamps
   50            buf(numhdr+j) = 0.
                 IF( IAND(lprint,8) .NE. 0 ) PRINT *,' zeroing from ',
     &               istart,' to ',nsamps
                 RETURN
             ENDIF
  100     CONTINUE
c***      Got here if finished the whole trace and all is ok
          RETURN
  110     CONTINUE
c****     Got here if we found the beginning and end of the "spikes"
          IF( kill .NE. 0 ) GOTO 9000
          IF( istart .EQ. 1 ) THEN
              DO 120 i = 1, iend
  120         buf(numhdr + i) = 0.
              IF( IAND(lprint,8).NE.0) PRINT *,' zeroing from 1 to ',iend
          ELSE
              n = iend - istart + 1
              x = ( buf(numhdr+iend+1)-buf(numhdr+istart-1) ) / FLOAT(n)
              IF( IAND(lprint,8) .NE. 0 ) PRINT *,' interpolating ',n,
     &               ' between ',istart-1,' to ',iend+1,' x=',x
              DO 150 i = istart, iend
                 buf(numhdr+i) = buf(numhdr+i-1) + x
  150         CONTINUE
          ENDIF
          is = iend + 1
          GOTO 10
      ENDIF
c****
c****    type 2 - Trehu/Sutton
c****    SES/SEL also uses fac
c****
      IF( fac .NE. 0. .AND. ses(1)+ses(2)+sel(1)+sel(2) .EQ. 0. ) THEN
          IF( IAND(lprint,2) .NE. 0 ) PRINT *,' Type 2 - Trehu/Sutton'
          DO 300 i = is+2, ie-2
             adiff1 = (ABS(scr(i-2)-scr(i-1))+ABS(scr(i+1)-scr(i+2)))/2.
             adiff2 = (ABS(scr(i-1)-scr(i)) + ABS(scr(i)-scr(i+1))) / 2.
             IF( adiff2 .GT. fac * adiff1 ) THEN
                 IF( kill .NE. 0 ) GOTO 9000
                 buf(numhdr+i) = (buf(numhdr+i+1) + buf(numhdr+i-1)) /2.
             ENDIF
  300     CONTINUE
      ENDIF
c****
c****    CWP/SU  Quartile
c****
      IF( quart .NE. 0. ) THEN
          IF( IAND(lprint,2) .NE. 0 ) PRINT *,' Type 3 - Quartile'
          k = NINT( quart * FLOAT(ie) )
          IF (K .LT. is ) K = is
          IF (K .GT. ie) K = ie
C         COMPUTE ABSOLUTE VALUES
          DO 310 I = 1, nsamps
             scr (I) = ABS (buf(numhdr+i))
  310     CONTINUE
C         FIND THE VALUE OF QUANTH SAMPLE BY PARTIALLY SORTING
          ILOW = is
          IHI  = ie
          DO WHILE (ILOW .LT. IHI)
             ak = scr (K)
             I  = ILOW
             J  = IHI
             DO WHILE (I .LE. J)
                DO WHILE (scr (I) .LT. ak)
                   I = I+1
                ENDDO
                DO WHILE (scr (J) .GT. ak)
                   J = J-1
                ENDDO
                IF (I .LE. J) THEN
                   TEMP = scr (I)
                   scr (I) = scr (J)
                   scr (J) = TEMP
                   I = I + 1
                   J = J - 1
                ENDIF
             ENDDO
             IF (J .LT. K) ILOW = I
             IF (I .GT. K) IHI  = J
          ENDDO
C         PERFORM THE CLIP
          ak = scr (K)
          DO 400 I = 1, nsamps
             IF( scr(i) .GT. ak) THEN
                 IF( kill .NE. 0 ) GOTO 9000
                 IF (buf(numhdr+i) .GT. 0.0) THEN
                    buf(numhdr+i) = ak
                 ELSE
                    buf(numhdr+i) = -ak
                 ENDIF
             ENDIF
  400    ENDDO
         RETURN
      ENDIF
c****
c****   SES/SEL   (short over long average)
c****
      IF( SES(2) .NE. 0. ) THEN
          IF( IAND(lprint,2) .NE. 0 ) PRINT *,' Type 4 - SES/SEL'
          time1 = ses(1)
          time2 = ses(2)
          time3 = sel(1)
          time4 = sel(2)
          IF( addwb .NE. 0 ) THEN
              time1 = time1 + buf(lwbtsptr)
              time2 = time2 + buf(lwbtsptr)
              time3 = time3 + buf(lwbtsptr)
              time4 = time4 + buf(lwbtsptr)
          ENDIF
          IF( vel .NE. 0 ) THEN
              range = FLOAT(lbuf(ldisptr))
              time1 = SQRT(time1*time1 + (range*range)/(vel*vel))
              time2 = SQRT(time2*time2 + (range*range)/(vel*vel))
              time3 = SQRT(time3*time3 + (range*range)/(vel*vel))
              time4 = SQRT(time4*time4 + (range*range)/(vel*vel))
          ENDIF
c****     This is stupid.  NINT((time1-delay) / buf(lsisptr))
c****     gives:    Note: IEEE floating-point exception flags raised:
c****           Inexact;  Invalid Operation;
c****     when the start/end time and the delay are less than a sample
c****     interval apart.  argh.
          IF( time1-delay .LT. buf(lsisptr) ) THEN
              is = 1
          ELSE
              is = NINT((time1-delay) / buf(lsisptr)) + 1
          ENDIF
          IF( time2-delay .LT. buf(lsisptr) ) THEN
              ie = 1
          ELSE
              ie = NINT((time2-delay) / buf(lsisptr)) + 1
          ENDIF
          IF( is .LT. 1 ) is = 1
          IF( ie .GT. nsamps ) ie = nsamps
c          print *,time1,delay,buf(lsisptr),is
c          print *,time2,delay,buf(lsisptr),ie
          IF( is .GE. ie ) THEN
              IF( iwarn1 .LT. 10 ) THEN
                  iwarn1 = iwarn1 + 1
                  PRINT *,' SES window is too short, no editing.'
              ENDIF
              RETURN
          ENDIF
          IF( pass(2) .NE. 0. .AND. kill .GT. 0 ) THEN
              IF( nfilpts .EQ. 0 ) THEN
                  CALL bpass( pass(1), pass(2), filpts, NPTS, si, scr )
                  nfilpts = NPTS
              ENDIF
              ldummy(1) = 1
              ldummy(2) = numdat
              CALL tvfilt( apdata(nextad), scr, apdata(nextad+numdat),
     &             filpts, nfilpts, 1., ldummy, 1, numdat )
          ENDIF
          ave1 = 0.
          DO i = is, ie
             ave1 = ave1 + ABS(scr(i))
          ENDDO
          ave1 = ave1 / FLOAT(ie-is+1)
          IF( time3-delay .LT. buf(lsisptr) ) THEN
              is = 1
          ELSE
              is = NINT((time2-delay) / buf(lsisptr)) + 1
          ENDIF
          IF( time4-delay .LT. buf(lsisptr) ) THEN
              ie = 1
          ELSE
              ie = NINT((time4-delay) / buf(lsisptr)) + 1
          ENDIF
          IF( is .LT. 1 ) is = 1
          IF( ie .GT. nsamps ) ie = nsamps
c          print *,time3,delay,buf(lsisptr),is
c          print *,time4,delay,buf(lsisptr),ie
          IF( is .GE. ie ) THEN
              IF( iwarn1 .LT. 10 ) THEN
                  iwarn1 = iwarn1 + 1
                  PRINT *,' SEL window is too short, no editing.'
              ENDIF
              RETURN
          ENDIF
          ave2 = 0.
          DO i = is, ie
             ave2 = ave2 + ABS(scr(i))
          ENDDO
          ave2 = ave2 / FLOAT(ie-is+1)
          IF( IAND(lprint,4) .NE. 0 ) THEN
              PRINT *,time1,time2,time3,time4
              PRINT *,' SES abs ave = ',ave1,' SEL abs ave = ',ave2
          ENDIF
          IF( ave1 / ave2 .GT. fac ) GOTO 9000
          RETURN
      ENDIF
c****
c****   Kill the trace if the average exceeds a threshold.  Only 1
c****   thres may be given.
c****
      IF( thres(1) .NE. 0. .AND. thres(2) .EQ. 0.) THEN
          IF( IAND(lprint,2) .NE. 0 ) PRINT *,' Type 5 - thres'
          ave1 = 0.
          DO i = is, ie
             ave1 = ave1 + ABS(scr(i))
          ENDDO
          ave1 = ave1 / FLOAT(ie-is+1)
          IF( IAND(lprint,4) .NE. 0 )
     &        PRINT *,' index ',is,' to ',ie,' ave= ',ave1
          IF( ave1 .GT. thres(1) ) GOTO 9000
          IF( set(3)+set(4) .NE. 0 ) THEN
              ave1 = 0.
              DO i = is2, ie2
                 ave1 = ave1 + ABS(scr(i))
              ENDDO
              ave1 = ave1 / FLOAT(ie2-is2+1)
              IF( IAND(lprint,4) .NE. 0 )
     &            PRINT *,' index',is2,' to ',ie2,' ave= ',ave1
              IF( ave1 .GT. thres(1) ) GOTO 9000
              RETURN
          ENDIF
      ENDIF
c****
c****   Detect dead traces if no value exceed VALMIN
c                 IF( token(1:6) .EQ. 'ABSVAL' ) maxtype = 1
c                 IF( token(1:4) .EQ. 'SDEV' ) maxtype = 2
c                 IF( token(1:3) .EQ. 'VAR' ) maxtype = 3
c                 IF( token(1:4) .EQ. 'SKEW' ) maxtype = 4
c                 IF( token(1:4) .EQ. 'KURT' ) maxtype =5
c****
      IF( valmin .NE. 0. .AND. mintype .EQ. 1 ) THEN
          IF( IAND(lprint,2) .NE. 0 ) PRINT *,' Type MINVAL'
          DO i = is, ie
             IF( ABS(scr(i)) .GE. valmin ) RETURN
          ENDDO
          GOTO 9000
      ENDIF
      IF( valmax .NE. 0 .AND. mintype .EQ. 1 ) THEN
          IF( IAND(lprint,2) .NE. 0 ) PRINT *,' Type MAXVAL'
          big = 0.
          DO i = is, ie
             IF( ABS(scr(i)) .GE. big ) big = ABS(scr(i))
          ENDDO
          IF( big .LE. valmax ) RETURN
          GOTO 9000
      ENDIF
      IF( valmin .NE. 0. .AND. mintype .EQ. 2 ) THEN
          CALL moment( scr(is), ie-is+1, ave, sdev, var, skew, curt )
          IF( IAND(lprint,16) .NE. 0 ) PRINT *,' std deviation=',sdev
          IF( sdev .GE. valmin ) RETURN
          GOTO 9000
      ENDIF
      IF( valmax .NE. 0. .AND. maxtype .EQ. 2 ) THEN
          CALL moment( scr(is), ie-is+1, ave, sdev, var, skew, curt )
          IF( IAND(lprint,16) .NE. 0 ) PRINT *,' std deviation=',sdev
          IF( sdev .LE. valmax ) RETURN
          GOTO 9000
      ENDIF
      IF( valmin .NE. 0. .AND. mintype .EQ. 3 ) THEN
          CALL moment( scr(is), ie-is+1, ave, sdev, var, skew, curt )
          IF( IAND(lprint,16) .NE. 0 ) PRINT *,' variance=',var
          IF( var .GE. valmin ) RETURN
          GOTO 9000
      ENDIF
      IF( valmax .NE. 0. .AND. maxtype .EQ. 3 ) THEN
          CALL moment( scr(is), ie-is+1, ave, sdev, var, skew, curt )
          IF( IAND(lprint,16) .NE. 0 ) PRINT *,' variance=',var
          IF( var .LE. valmax ) RETURN
          GOTO 9000
      ENDIF
      IF( valmin .NE. 0. .AND. mintype .EQ. 4 ) THEN
          CALL moment( scr(is), ie-is+1, ave, sdev, var, skew, curt )
          IF( IAND(lprint,16) .NE. 0 ) PRINT *,' skewness=',skew
          IF( skew .GE. valmin ) RETURN
          GOTO 9000
      ENDIF
      IF( valmax .NE. 0. .AND. maxtype .EQ. 4 ) THEN
          CALL moment( scr(is), ie-is+1, ave, sdev, var, skew, curt )
          IF( IAND(lprint,16) .NE. 0 ) PRINT *,' skewness=',skew
          IF( skew .LE. valmax ) RETURN
          GOTO 9000
      ENDIF
      IF( valmin .NE. 0. .AND. mintype .EQ. 5 ) THEN
          CALL moment( scr(is), ie-is+1, ave, adev, sdev, var,skew,curt)
          IF( IAND(lprint,16) .NE. 0 ) PRINT *,' kurtosis=',curt
          IF( curt .GE. valmin ) RETURN
          GOTO 9000
      ENDIF
      IF( valmax .NE. 0. .AND. maxtype .EQ. 5 ) THEN
          CALL moment( scr(is), ie-is+1, ave, sdev, var, skew, curt )
          IF( IAND(lprint,16) .NE. 0 ) PRINT *,' kurtosis=',curt
          IF( curt .LE. valmax ) RETURN
          GOTO 9000
      ENDIF
c****
c****   Kill/keep by header value
c****         KILL 2 (INSIDE) means to kill the trace if the header
c****               value is inside the limits.
c****         KILL 3 (OUTSIDE)  means to kill the trace if the header
c****               value is outside the limits.
c****
      IF( limits(1) .NE. -999999. ) THEN
          IF( IAND(lprint,2) .NE. 0 ) PRINT *,' Type LIMITS'
          IF( ihdr .NE. 0 ) THEN
              index = ihdr
              value = ibuf(index)
          ENDIF
          IF( lhdr .NE. 0 ) value = lbuf(lhdr)
          IF( hdr .NE. 0. ) THEN
              index = NINT(hdr)
              value = buf(index)
          ENDIF
          IF( kill .EQ. 2 ) THEN
              IF( value .GE. limits(1).AND.value.LE.limits(2)) GOTO 9000
          ENDIF
          IF( kill .EQ. 3 ) THEN
              IF( value .LT. limits(1) .OR.value.GT.limits(2)) GOTO 9000
          ENDIF
      ENDIF
c****
c****  LTZ - Local Trace Zeroing
c****
      IF( winlen .NE. 0. ) THEN
          nwin = NINT(winlen/buf(lsisptr))
          nwin2 = NINT(winlen/buf(lsisptr)/2.)
          nhcycle = hcycle/buf(lsisptr)
c	 print *,nwin, nwin2, ' nhcycle=', nhcycle,' nsamps=',nsamps
          ave = 0.
          DO i = 1, nwin
             ave = ave + buf(numhdr+i)
          ENDDO
c****     find the "average" window amplitude (sum of amplitudes) for all windows
          apdata(nextad) = ave
c	 print *,' index=',(nextad),' ave=',ave
          DO i = 1, nsamps - nwin - 1
             ave = ave - buf(numhdr+i) + buf(numhdr+nwin+i)
             apdata(nextad+i) = ave
c	 print *,' index=',(nextad+i), buf(numhdr+i),
c     &  buf(numhdr+nwin+i),' ave=',apdata(nextad+i)
          ENDDO
c****     find the zero crossings of the window averages
          nz = 0
          DO i = nextad, nextad+nsamps-nwin
c	 print *,' i=',i,apdata(i) * apdata(i+1),apdata(i),apdata(i+1)
             IF( apdata(i) * apdata(i+1) .LE. 0 ) THEN
                 nz = nz + 1
                 lscr(nz) = i
c	 print *,' i=',i,' nz=',nz,' crossing at ',lscr(nz)
             ENDIF
          ENDDO
c****     zero the window if zero crossing exceeds hcycle (half cycle)
          IF( nz .GT. 0 ) THEN
              IF( lscr(1) .GT. nhcycle ) THEN
c	 print *,' zeroing from 1 to ',lscr(1)
                  DO j = 1, lscr(1)
                     buf(numhdr+j) = 0.
                  ENDDO
              ENDIF
              DO i = 1, nz-1
                 IF( lscr(i+1) - lscr(i) .GT. nhcycle ) THEN
c	 print *,' zeroing from',lscr(i),' to ',lscr(i+1)
                     DO j = lscr(i), lscr(i+1)
                        buf(numhdr+j) = 0.
                     ENDDO
                 ENDIF
              ENDDO
          ELSE
              PRINT *,' ***  Warning  ***  Trace had no zero crossings.'
          ENDIF
      ENDIF

      RETURN
c****
c****   KILL the trace
c****
 9000 CONTINUE
      IF( IAND(lprint,8) .NE. 0 ) PRINT *,' Killing shot ',lbuf(3),
     &   ' trace ', lbuf(4), ' rp ', lbuf(6), ' trace ', lbuf(7)
      IF( kill .NE. 4 ) THEN
          DO i = 1, nsamps
             buf(numhdr+i) = 0.
          ENDDO
      ENDIF
      ibuf(itridptr) = 2
      RETURN

      END


      double complex function A0HAQggmppp(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      double complex A0phidAQggmppp
      integer j1,j2,j3,j4

      A0HAQggmppp=
c     .  A0phiAQggmppp(j1,j2,j3,j4,za,zb)   ! This amplitude is zero
     .  +A0phidAQggmppp(j1,j2,j3,j4,za,zb)

      return
      end

      double complex function A0HAQggmpmm(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      double complex A0phiAQggmpmm
      integer j1,j2,j3,j4

      A0HAQggmpmm=
     .    A0phiAQggmpmm(j1,j2,j3,j4,za,zb)
c     .  +A0phidAQggmpmm(j1,j2,j3,j4,za,zb)   ! This amplitude is zero

      return
      end

      double complex function A0HAQggmpmp(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      double complex A0phiAQggmpmp,A0phidAQggmpmp
      integer j1,j2,j3,j4

      A0HAQggmpmp=
     .    A0phiAQggmpmp(j1,j2,j3,j4,za,zb)
     .  +A0phidAQggmpmp(j1,j2,j3,j4,za,zb)

      return
      end

      double complex function A0HAQggmppm(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      double complex A0phiAQggmppm,A0phidAQggmppm
      integer j1,j2,j3,j4

      A0HAQggmppm=
     .    A0phiAQggmppm(j1,j2,j3,j4,za,zb)
     .  +A0phidAQggmppm(j1,j2,j3,j4,za,zb)

      return
      end


! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Parameter Module File
!
! Generated by KPP-2.1 symbolic chemistry Kinetics PreProcessor
!       (http://www.cs.vt.edu/~asandu/Software/KPP)
! KPP is distributed under GPL, the general public licence
!       (http://www.gnu.org/copyleft/gpl.html)
! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa
! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech
!     With important contributions from:
!        M. Damian, Villanova University, USA
!        R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany
!
! File                 : saprc99_Parameters.f90
! Time                 : Wed Jun 14 17:35:32 2017
! Working directory    : /data/ksetigui/setigui/WRFnew/chem/KPP/mechanisms/saprc99
! Equation file        : saprc99.kpp
! Output root filename : saprc99
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

MODULE saprc99_Parameters

  USE saprc99_Precision
  PUBLIC
  SAVE

! NSPEC - Number of chemical species
  INTEGER, PARAMETER :: NSPEC = 81
! NVAR - Number of Variable species
  INTEGER, PARAMETER :: NVAR = 79
! NVARACT - Number of Active species
  INTEGER, PARAMETER :: NVARACT = 72
! NFIX - Number of Fixed species
  INTEGER, PARAMETER :: NFIX = 2
! NREACT - Number of reactions
  INTEGER, PARAMETER :: NREACT = 225
! NVARST - Starting of variables in conc. vect.
  INTEGER, PARAMETER :: NVARST = 1
! NFIXST - Starting of fixed in conc. vect.
  INTEGER, PARAMETER :: NFIXST = 80
! NONZERO - Number of nonzero entries in Jacobian
  INTEGER, PARAMETER :: NONZERO = 887
! LU_NONZERO - Number of nonzero entries in LU factoriz. of Jacobian
  INTEGER, PARAMETER :: LU_NONZERO = 968
! CNVAR - (NVAR+1) Number of elements in compressed row format
  INTEGER, PARAMETER :: CNVAR = 80
! NLOOKAT - Number of species to look at
  INTEGER, PARAMETER :: NLOOKAT = 0
! NMONITOR - Number of species to monitor
  INTEGER, PARAMETER :: NMONITOR = 0
! NMASS - Number of atoms to check mass balance
  INTEGER, PARAMETER :: NMASS = 1
! PI - Value of pi
  REAL(kind=dp), PARAMETER :: PI = 3.14159265358979

! Index declaration for variable species in C and VAR
!   VAR(ind_spc) = C(ind_spc)

  INTEGER, PARAMETER :: ind_H2SO4 = 1
  INTEGER, PARAMETER :: ind_CO2 = 2
  INTEGER, PARAMETER :: ind_HCOOH = 3
  INTEGER, PARAMETER :: ind_CCO_OH = 4
  INTEGER, PARAMETER :: ind_RCO_OH = 5
  INTEGER, PARAMETER :: ind_CCO_OOH = 6
  INTEGER, PARAMETER :: ind_RCO_OOH = 7
  INTEGER, PARAMETER :: ind_XN = 8
  INTEGER, PARAMETER :: ind_XC = 9
  INTEGER, PARAMETER :: ind_SO2 = 10
  INTEGER, PARAMETER :: ind_O1D = 11
  INTEGER, PARAMETER :: ind_CH4 = 12
  INTEGER, PARAMETER :: ind_C2H6 = 13
  INTEGER, PARAMETER :: ind_BACL = 14
  INTEGER, PARAMETER :: ind_PAN = 15
  INTEGER, PARAMETER :: ind_PAN2 = 16
  INTEGER, PARAMETER :: ind_PBZN = 17
  INTEGER, PARAMETER :: ind_MA_PAN = 18
  INTEGER, PARAMETER :: ind_H2O2 = 19
  INTEGER, PARAMETER :: ind_C3H8 = 20
  INTEGER, PARAMETER :: ind_ETOH = 21
  INTEGER, PARAMETER :: ind_N2O5 = 22
  INTEGER, PARAMETER :: ind_HONO = 23
  INTEGER, PARAMETER :: ind_ALK3 = 24
  INTEGER, PARAMETER :: ind_TBU_O = 25
  INTEGER, PARAMETER :: ind_ALK5 = 26
  INTEGER, PARAMETER :: ind_ARO2 = 27
  INTEGER, PARAMETER :: ind_MEOH = 28
  INTEGER, PARAMETER :: ind_COOH = 29
  INTEGER, PARAMETER :: ind_HOCOO = 30
  INTEGER, PARAMETER :: ind_BZNO2_O = 31
  INTEGER, PARAMETER :: ind_HNO4 = 32
  INTEGER, PARAMETER :: ind_ALK4 = 33
  INTEGER, PARAMETER :: ind_ARO1 = 34
  INTEGER, PARAMETER :: ind_DCB2 = 35
  INTEGER, PARAMETER :: ind_DCB3 = 36
  INTEGER, PARAMETER :: ind_CRES = 37
  INTEGER, PARAMETER :: ind_DCB1 = 38
  INTEGER, PARAMETER :: ind_C2H2 = 39
  INTEGER, PARAMETER :: ind_NPHE = 40
  INTEGER, PARAMETER :: ind_BALD = 41
  INTEGER, PARAMETER :: ind_ROOH = 42
  INTEGER, PARAMETER :: ind_PHEN = 43
  INTEGER, PARAMETER :: ind_MGLY = 44
  INTEGER, PARAMETER :: ind_CO = 45
  INTEGER, PARAMETER :: ind_ACET = 46
  INTEGER, PARAMETER :: ind_HNO3 = 47
  INTEGER, PARAMETER :: ind_ETHENE = 48
  INTEGER, PARAMETER :: ind_GLY = 49
  INTEGER, PARAMETER :: ind_C3H6 = 50
  INTEGER, PARAMETER :: ind_BZ_O = 51
  INTEGER, PARAMETER :: ind_ISOPRENE = 52
  INTEGER, PARAMETER :: ind_R2O2 = 53
  INTEGER, PARAMETER :: ind_TERP = 54
  INTEGER, PARAMETER :: ind_METHACRO = 55
  INTEGER, PARAMETER :: ind_OLE1 = 56
  INTEGER, PARAMETER :: ind_ISOPROD = 57
  INTEGER, PARAMETER :: ind_OLE2 = 58
  INTEGER, PARAMETER :: ind_MVK = 59
  INTEGER, PARAMETER :: ind_CCHO = 60
  INTEGER, PARAMETER :: ind_HCHO = 61
  INTEGER, PARAMETER :: ind_RNO3 = 62
  INTEGER, PARAMETER :: ind_O3P = 63
  INTEGER, PARAMETER :: ind_RCHO = 64
  INTEGER, PARAMETER :: ind_MEK = 65
  INTEGER, PARAMETER :: ind_PROD2 = 66
  INTEGER, PARAMETER :: ind_O3 = 67
  INTEGER, PARAMETER :: ind_CCO_O2 = 68
  INTEGER, PARAMETER :: ind_RO2_N = 69
  INTEGER, PARAMETER :: ind_MA_RCO3 = 70
  INTEGER, PARAMETER :: ind_OH = 71
  INTEGER, PARAMETER :: ind_RCO_O2 = 72
  INTEGER, PARAMETER :: ind_NO = 73
  INTEGER, PARAMETER :: ind_NO2 = 74
  INTEGER, PARAMETER :: ind_NO3 = 75
  INTEGER, PARAMETER :: ind_C_O2 = 76
  INTEGER, PARAMETER :: ind_RO2_R = 77
  INTEGER, PARAMETER :: ind_HO2 = 78
  INTEGER, PARAMETER :: ind_BZCO_O2 = 79

! Index declaration for fixed species in C
!   C(ind_spc)

  INTEGER, PARAMETER :: ind_H2O = 80
  INTEGER, PARAMETER :: ind_M = 81

! Index declaration for fixed species in FIX
!    FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)

  INTEGER, PARAMETER :: indf_H2O = 1
  INTEGER, PARAMETER :: indf_M = 2

END MODULE saprc99_Parameters


*DECK DLSOD
      SUBROUTINE DLSOD (DF, NEQ, T, Y, TOUT, RTOL, ATOL, IDID, YPOUT,
     +   YH, YH1, EWT, SAVF, ACOR, WM, IWM, DJAC, INTOUT, TSTOP, TOLFAC,
     +   DELSGN, RPAR, IPAR)
C***BEGIN PROLOGUE  DLSOD
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DDEBDF
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (LSOD-S, DLSOD-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C   DDEBDF  merely allocates storage for  DLSOD  to relieve the user of
C   the inconvenience of a long call list.  Consequently  DLSOD  is used
C   as described in the comments for  DDEBDF .
C
C***SEE ALSO  DDEBDF
C***ROUTINES CALLED  D1MACH, DHSTRT, DINTYD, DSTOD, DVNRMS, XERMSG
C***COMMON BLOCKS    DDEBD1
C***REVISION HISTORY  (YYMMDD)
C   820301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C***END PROLOGUE  DLSOD
C
      INTEGER IBAND, IBEGIN, IDID, IER, IINTEG, IJAC, INIT, INTFLG,
     1      IOWNS, IPAR, IQUIT, ITOL, ITSTOP, IWM, JSTART, K, KFLAG,
     2      KSTEPS, L, LACOR, LDUM, LEWT, LSAVF, LTOL, LWM, LYH, MAXNUM,
     3      MAXORD, METH, MITER, N, NATOLP, NEQ, NFE, NJE, NQ, NQU,
     4      NRTOLP, NST
      DOUBLE PRECISION ABSDEL, ACOR, ATOL, BIG, D1MACH, DEL,
     1      DELSGN, DT, DVNRMS, EL0, EWT,
     2      H, HA, HMIN, HMXI, HU, ROWNS, RPAR, RTOL, SAVF, T, TOL,
     3      TOLD, TOLFAC, TOUT, TSTOP, U, WM, X, Y, YH, YH1, YPOUT
      LOGICAL INTOUT
      CHARACTER*8 XERN1
      CHARACTER*16 XERN3, XERN4
C
      DIMENSION Y(*),YPOUT(*),YH(NEQ,6),YH1(*),EWT(*),SAVF(*),
     1          ACOR(*),WM(*),IWM(*),RTOL(*),ATOL(*),RPAR(*),IPAR(*)
C
C
      COMMON /DDEBD1/ TOLD,ROWNS(210),EL0,H,HMIN,HMXI,HU,X,U,IQUIT,INIT,
     1                LYH,LEWT,LACOR,LSAVF,LWM,KSTEPS,IBEGIN,ITOL,
     2                IINTEG,ITSTOP,IJAC,IBAND,IOWNS(6),IER,JSTART,
     3                KFLAG,LDUM,METH,MITER,MAXORD,N,NQ,NST,NFE,NJE,NQU
C
      EXTERNAL DF, DJAC
C
C     ..................................................................
C
C       THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE
C       NUMBER OF  STEPS ATTEMPTED. WHEN THIS EXCEEDS  MAXNUM, THE
C       COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE
C       EXCESSIVE WORK.
      SAVE MAXNUM
C
      DATA MAXNUM /500/
C
C     ..................................................................
C
C***FIRST EXECUTABLE STATEMENT  DLSOD
      IF (IBEGIN .EQ. 0) THEN
C
C        ON THE FIRST CALL , PERFORM INITIALIZATION --
C        DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY  U  BY CALLING THE
C        FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE
C        VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED.
C
         U = D1MACH(4)
C                          -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER
         WM(1) = SQRT(U)
C                          -- SET TERMINATION FLAG
         IQUIT = 0
C                          -- SET INITIALIZATION INDICATOR
         INIT = 0
C                          -- SET COUNTER FOR ATTEMPTED STEPS
         KSTEPS = 0
C                          -- SET INDICATOR FOR INTERMEDIATE-OUTPUT
         INTOUT = .FALSE.
C                          -- SET START INDICATOR FOR DSTOD CODE
         JSTART = 0
C                          -- SET BDF METHOD INDICATOR
         METH = 2
C                          -- SET MAXIMUM ORDER FOR BDF METHOD
         MAXORD = 5
C                          -- SET ITERATION MATRIX INDICATOR
C
         IF (IJAC .EQ. 0 .AND. IBAND .EQ. 0) MITER = 2
         IF (IJAC .EQ. 1 .AND. IBAND .EQ. 0) MITER = 1
         IF (IJAC .EQ. 0 .AND. IBAND .EQ. 1) MITER = 5
         IF (IJAC .EQ. 1 .AND. IBAND .EQ. 1) MITER = 4
C
C                          -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK
         N = NEQ
         NST = 0
         NJE = 0
         HMXI = 0.0D0
         NQ = 1
         H = 1.0D0
C                          -- RESET IBEGIN FOR SUBSEQUENT CALLS
         IBEGIN = 1
      ENDIF
C
C     ..................................................................
C
C      CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY
C
      IF (NEQ .LT. 1) THEN
         WRITE (XERN1, '(I8)') NEQ
         CALL XERMSG ('SLATEC', 'DLSOD',
     *      'IN DDEBDF, THE NUMBER OF EQUATIONS MUST BE A ' //
     *      'POSITIVE INTEGER.$$YOU HAVE CALLED THE CODE WITH NEQ = ' //
     *      XERN1, 6, 1)
         IDID=-33
      ENDIF
C
      NRTOLP = 0
      NATOLP = 0
      DO 60 K = 1, NEQ
         IF (NRTOLP .LE. 0) THEN
            IF (RTOL(K) .LT. 0.) THEN
               WRITE (XERN1, '(I8)') K
               WRITE (XERN3, '(1PE15.6)') RTOL(K)
               CALL XERMSG ('SLATEC', 'DLSOD',
     *            'IN DDEBDF, THE RELATIVE ERROR TOLERANCES MUST ' //
     *            'BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE WITH ' //
     *            'RTOL(' // XERN1 // ') = ' // XERN3 // '$$IN THE ' //
     *            'CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' //
     *            'CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1)
               IDID = -33
               IF (NATOLP .GT. 0) GO TO 70
               NRTOLP = 1
            ELSEIF (NATOLP .GT. 0) THEN
               GO TO 50
            ENDIF
         ENDIF
C
         IF (ATOL(K) .LT. 0.) THEN
            WRITE (XERN1, '(I8)') K
            WRITE (XERN3, '(1PE15.6)') ATOL(K)
            CALL XERMSG ('SLATEC', 'DLSOD',
     *         'IN DDEBDF, THE ABSOLUTE ERROR ' //
     *         'TOLERANCES MUST BE NON-NEGATIVE.$$YOU HAVE CALLED ' //
     *         'THE CODE WITH ATOL(' // XERN1 // ') = ' // XERN3 //
     *         '$$IN THE CASE OF VECTOR ERROR TOLERANCES, NO FURTHER '
     *         // 'CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1)
            IDID=-33
            IF (NRTOLP .GT. 0) GO TO 70
            NATOLP=1
         ENDIF
   50    IF (ITOL .EQ. 0) GO TO 70
   60 CONTINUE
C
   70 IF (ITSTOP .EQ. 1) THEN
         IF (SIGN(1.0D0,TOUT-T) .NE. SIGN(1.0D0,TSTOP-T) .OR.
     1      ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN
            WRITE (XERN3, '(1PE15.6)') TOUT
            WRITE (XERN4, '(1PE15.6)') TSTOP
            CALL XERMSG ('SLATEC', 'DLSOD',
     *         'IN DDEBDF, YOU HAVE CALLED THE ' //
     *         'CODE WITH TOUT = ' // XERN3 // '$$BUT YOU HAVE ' //
     *         'ALSO TOLD THE CODE NOT TO INTEGRATE PAST THE POINT ' //
     *         'TSTOP = ' // XERN4 // ' BY SETTING INFO(4) = 1.$$' //
     *         'THESE INSTRUCTIONS CONFLICT.', 14, 1)
            IDID=-33
         ENDIF
      ENDIF
C
C        CHECK SOME CONTINUATION POSSIBILITIES
C
      IF (INIT .NE. 0) THEN
         IF (T .EQ. TOUT) THEN
            WRITE (XERN3, '(1PE15.6)') T
            CALL XERMSG ('SLATEC', 'DLSOD',
     *         'IN DDEBDF, YOU HAVE CALLED THE CODE WITH T = TOUT = ' //
     *         XERN3 // '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.',
     *         9, 1)
            IDID=-33
         ENDIF
C
         IF (T .NE. TOLD) THEN
            WRITE (XERN3, '(1PE15.6)') TOLD
            WRITE (XERN4, '(1PE15.6)') T
            CALL XERMSG ('SLATEC', 'DLSOD',
     *         'IN DDEBDF, YOU HAVE CHANGED THE VALUE OF T FROM ' //
     *         XERN3 // ' TO ' // XERN4 //
     *         '  THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1)
            IDID=-33
         ENDIF
C
         IF (INIT .NE. 1) THEN
            IF (DELSGN*(TOUT-T) .LT. 0.0D0) THEN
               WRITE (XERN3, '(1PE15.6)') TOUT
               CALL XERMSG ('SLATEC', 'DLSOD',
     *            'IN DDEBDF, BY CALLING THE CODE WITH TOUT = ' //
     *            XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' //
     *            'DIRECTION OF INTEGRATION.$$THIS IS NOT ALLOWED ' //
     *            'WITHOUT RESTARTING.', 11, 1)
               IDID=-33
            ENDIF
         ENDIF
      ENDIF
C
      IF (IDID .EQ. (-33)) THEN
         IF (IQUIT .NE. (-33)) THEN
C                       INVALID INPUT DETECTED
            IQUIT=-33
            IBEGIN=-1
         ELSE
            CALL XERMSG ('SLATEC', 'DLSOD',
     *         'IN DDEBDF, INVALID INPUT WAS DETECTED ON ' //
     *         'SUCCESSIVE ENTRIES.  IT IS IMPOSSIBLE TO PROCEED ' //
     *         'BECAUSE YOU HAVE NOT CORRECTED THE PROBLEM, ' //
     *         'SO EXECUTION IS BEING TERMINATED.', 12, 2)
         ENDIF
         RETURN
      ENDIF
C
C        ...............................................................
C
C             RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED
C             AS ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS
C             CASE, THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE
C             SMALLEST VALUE 100*U WHICH IS LIKELY TO BE REASONABLE FOR
C             THIS METHOD AND MACHINE
C
      DO 180 K = 1, NEQ
         IF (RTOL(K) + ATOL(K) .GT. 0.0D0) GO TO 170
            RTOL(K) = 100.0D0*U
            IDID = -2
  170    CONTINUE
C     ...EXIT
         IF (ITOL .EQ. 0) GO TO 190
  180 CONTINUE
  190 CONTINUE
C
      IF (IDID .NE. (-2)) GO TO 200
C        RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A
C                                 SMALL POSITIVE VALUE
         IBEGIN = -1
      GO TO 460
  200 CONTINUE
C        BEGIN BLOCK PERMITTING ...EXITS TO 450
C           BEGIN BLOCK PERMITTING ...EXITS TO 430
C              BEGIN BLOCK PERMITTING ...EXITS TO 260
C                 BEGIN BLOCK PERMITTING ...EXITS TO 230
C
C                    BRANCH ON STATUS OF INITIALIZATION INDICATOR
C                           INIT=0 MEANS INITIAL DERIVATIVES AND
C                           NOMINAL STEP SIZE
C                                  AND DIRECTION NOT YET SET
C                           INIT=1 MEANS NOMINAL STEP SIZE AND
C                           DIRECTION NOT YET SET INIT=2 MEANS NO
C                           FURTHER INITIALIZATION REQUIRED
C
                     IF (INIT .EQ. 0) GO TO 210
C                 ......EXIT
                        IF (INIT .EQ. 1) GO TO 230
C              .........EXIT
                        GO TO 260
  210                CONTINUE
C
C                    ................................................
C
C                         MORE INITIALIZATION --
C                                             -- EVALUATE INITIAL
C                                             DERIVATIVES
C
                     INIT = 1
                     CALL DF(T,Y,YH(1,2),RPAR,IPAR)
                     NFE = 1
C                 ...EXIT
                     IF (T .NE. TOUT) GO TO 230
                     IDID = 2
                     DO 220 L = 1, NEQ
                        YPOUT(L) = YH(L,2)
  220                CONTINUE
                     TOLD = T
C        ............EXIT
                     GO TO 450
  230             CONTINUE
C
C                 -- COMPUTE INITIAL STEP SIZE
C                 -- SAVE SIGN OF INTEGRATION DIRECTION
C                 -- SET INDEPENDENT AND DEPENDENT VARIABLES
C                                      X AND YH(*) FOR DSTOD
C
                  LTOL = 1
                  DO 240 L = 1, NEQ
                     IF (ITOL .EQ. 1) LTOL = L
                     TOL = RTOL(LTOL)*ABS(Y(L)) + ATOL(LTOL)
                     IF (TOL .EQ. 0.0D0) GO TO 390
                     EWT(L) = TOL
  240             CONTINUE
C
                  BIG = SQRT(D1MACH(2))
                  CALL DHSTRT(DF,NEQ,T,TOUT,Y,YH(1,2),EWT,1,U,BIG,
     1                        YH(1,3),YH(1,4),YH(1,5),YH(1,6),RPAR,
     2                        IPAR,H)
C
                  DELSGN = SIGN(1.0D0,TOUT-T)
                  X = T
                  DO 250 L = 1, NEQ
                     YH(L,1) = Y(L)
                     YH(L,2) = H*YH(L,2)
  250             CONTINUE
                  INIT = 2
  260          CONTINUE
C
C              ......................................................
C
C                 ON EACH CALL SET INFORMATION WHICH DETERMINES THE
C                 ALLOWED INTERVAL OF INTEGRATION BEFORE RETURNING
C                 WITH AN ANSWER AT TOUT
C
               DEL = TOUT - T
               ABSDEL = ABS(DEL)
C
C              ......................................................
C
C                 IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND
C                 RETURN
C
  270          CONTINUE
C                 BEGIN BLOCK PERMITTING ...EXITS TO 400
C                    BEGIN BLOCK PERMITTING ...EXITS TO 380
                        IF (ABS(X-T) .LT. ABSDEL) GO TO 290
                           CALL DINTYD(TOUT,0,YH,NEQ,Y,INTFLG)
                           CALL DINTYD(TOUT,1,YH,NEQ,YPOUT,INTFLG)
                           IDID = 3
                           IF (X .NE. TOUT) GO TO 280
                              IDID = 2
                              INTOUT = .FALSE.
  280                      CONTINUE
                           T = TOUT
                           TOLD = T
C        ..................EXIT
                           GO TO 450
  290                   CONTINUE
C
C                       IF CANNOT GO PAST TSTOP AND SUFFICIENTLY
C                       CLOSE, EXTRAPOLATE AND RETURN
C
                        IF (ITSTOP .NE. 1) GO TO 310
                        IF (ABS(TSTOP-X) .GE. 100.0D0*U*ABS(X))
     1                     GO TO 310
                           DT = TOUT - X
                           DO 300 L = 1, NEQ
                              Y(L) = YH(L,1) + (DT/H)*YH(L,2)
  300                      CONTINUE
                           CALL DF(TOUT,Y,YPOUT,RPAR,IPAR)
                           NFE = NFE + 1
                           IDID = 3
                           T = TOUT
                           TOLD = T
C        ..................EXIT
                           GO TO 450
  310                   CONTINUE
C
                        IF (IINTEG .EQ. 0 .OR. .NOT.INTOUT) GO TO 320
C
C                          INTERMEDIATE-OUTPUT MODE
C
                           IDID = 1
                        GO TO 370
  320                   CONTINUE
C
C                       .............................................
C
C                            MONITOR NUMBER OF STEPS ATTEMPTED
C
                        IF (KSTEPS .LE. MAXNUM) GO TO 330
C
C                          A SIGNIFICANT AMOUNT OF WORK HAS BEEN
C                          EXPENDED
                           IDID = -1
                           KSTEPS = 0
                           IBEGIN = -1
                        GO TO 370
  330                   CONTINUE
C
C                          ..........................................
C
C                             LIMIT STEP SIZE AND SET WEIGHT VECTOR
C
                           HMIN = 100.0D0*U*ABS(X)
                           HA = MAX(ABS(H),HMIN)
                           IF (ITSTOP .EQ. 1)
     1                        HA = MIN(HA,ABS(TSTOP-X))
                           H = SIGN(HA,H)
                           LTOL = 1
                           DO 340 L = 1, NEQ
                              IF (ITOL .EQ. 1) LTOL = L
                              EWT(L) = RTOL(LTOL)*ABS(YH(L,1))
     1                                 + ATOL(LTOL)
C                    .........EXIT
                              IF (EWT(L) .LE. 0.0D0) GO TO 380
  340                      CONTINUE
                           TOLFAC = U*DVNRMS(NEQ,YH,EWT)
C                 .........EXIT
                           IF (TOLFAC .LE. 1.0D0) GO TO 400
C
C                          TOLERANCES TOO SMALL
                           IDID = -2
                           TOLFAC = 2.0D0*TOLFAC
                           RTOL(1) = TOLFAC*RTOL(1)
                           ATOL(1) = TOLFAC*ATOL(1)
                           IF (ITOL .EQ. 0) GO TO 360
                              DO 350 L = 2, NEQ
                                 RTOL(L) = TOLFAC*RTOL(L)
                                 ATOL(L) = TOLFAC*ATOL(L)
  350                         CONTINUE
  360                      CONTINUE
                           IBEGIN = -1
  370                   CONTINUE
C           ............EXIT
                        GO TO 430
  380                CONTINUE
C
C                    RELATIVE ERROR CRITERION INAPPROPRIATE
  390                CONTINUE
                     IDID = -3
                     IBEGIN = -1
C           .........EXIT
                     GO TO 430
  400             CONTINUE
C
C                 ...................................................
C
C                      TAKE A STEP
C
                  CALL DSTOD(NEQ,Y,YH,NEQ,YH1,EWT,SAVF,ACOR,WM,IWM,
     1                       DF,DJAC,RPAR,IPAR)
C
                  JSTART = -2
                  INTOUT = .TRUE.
               IF (KFLAG .EQ. 0) GO TO 270
C
C              ......................................................
C
               IF (KFLAG .EQ. -1) GO TO 410
C
C                 REPEATED CORRECTOR CONVERGENCE FAILURES
                  IDID = -6
                  IBEGIN = -1
               GO TO 420
  410          CONTINUE
C
C                 REPEATED ERROR TEST FAILURES
                  IDID = -7
                  IBEGIN = -1
  420          CONTINUE
  430       CONTINUE
C
C           .........................................................
C
C                                  STORE VALUES BEFORE RETURNING TO
C                                  DDEBDF
            DO 440 L = 1, NEQ
               Y(L) = YH(L,1)
               YPOUT(L) = YH(L,2)/H
  440       CONTINUE
            T = X
            TOLD = T
            INTOUT = .FALSE.
  450    CONTINUE
  460 CONTINUE
      RETURN
      END