      subroutine graze

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine simulates biomass lost to grazing

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name         |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bactkddb(:)  |none          |bacteria partition coefficient:
!!                                |1: all bacteria in solution
!!                                |0: all bacteria sorbed to soil particles
!!    bactlp_plt(:)|# cfu/m^2     |less persistent bacteria on foliage
!!    bactlpdb(:)  |# cfu/g       |concentration of less persistent
!!                                |bacteria in manure(fertilizer)
!!    bactlpq(:)   |# cfu/m^2     |less persistent bacteria in soil solution
!!    bactlps(:)   |# cfu/m^2     |less persistent bacteria attached to soil
!!                                |particles
!!    bactp_plt(:) |# cfu/m^2     |persistent bacteria on foliage
!!    bactpdb(:)   |# cfu/g       |concentration of persistent bacteria
!!                                |in manure(fertilizer)
!!    bactpq(:)    |# cfu/m^2     |persistent bacteria in soil solution
!!    bactps(:)    |# cfu/m^2     |persistent bacteria attached to soil particles
!!    bio_min(:)   |kg/ha         |minimum plant biomass for grazing
!!    bio_ms(:)    |kg/ha         |land cover/crop biomass (dry weight)
!!    bio_eat(:)   |(kg/ha)/day   |dry weight of biomass removed by grazing
!!                                |daily
!!    bio_trmp(:)  |(kg/ha)/day   |dry weight of biomass removed by
!!                                |trampling daily
!!    curyr        |none          |current year of simulation
!!    fminn(:)     |kg minN/kg frt|fraction of mineral N (NO3 + NH3) in
!!                                |fertilizer/manure
!!    fminp(:)     |kg minP/kg frt|fraction of mineral P in fertilizer/manure
!!    fnh3n(:)     |kg NH3-N/kg minN|fraction of NH3-N in mineral N in
!!                                |fertilizer/manure
!!    forgn(:)     |kg orgN/kg frt|fraction of organic N in fertilizer/manure
!!    forgp(:)     |kg orgP/kg frt|fraction of organic P in fertilizer/manure
!!    grazn        |kg N/ha       |total amount of nitrogen applied to soil
!!                                |during grazing in HRU on day
!!    grazp        |kg P/ha       |total amount of phosphorus applied to soil
!!                                |during grazing in HRU on day
!!    hru_dafr(:)  |km**2/km**2   |fraction of watershed area in HRU
!!    icr(:)       |none          |sequence number of crop grown within the
!!                                |current year
!!    iida         |julian date   |day being simulated (current julian day
!!    manure_id(:) |none          |manure (fertilizer) identification
!!                                |number from fert.dat
!!    igrz(:)      |none          |grazing flag for HRU:
!!                                |0 HRU currently not grazed
!!                                |1 HRU currently grazed
!!    ihru         |none          |HRU number
!!    laiday(:)    |m**2/m**2     |leaf area index
!!    grz_days(:)  |none          |number of days grazing will be simulated
!!    ngr(:)       |none          |sequence number of grazing operation
!!                                |within the year
!!    nro(:)       |none          |sequence number of year in rotation
!!    nyskip       |none          |number of years to skip output summarization
!!                                |and printing
!!    phuacc(:)    |none          |fraction of plant heat units accumulated
!!    phug(:,:,:)  |none          |fraction of plant heat units at which
!!                                |grazing begins
!!    plantn(:)    |kg N/ha       |amount of nitrogen in plant
!!    plantp(:)    |kg P/ha       |amount of phosphorus in plant
!!    pltfr_n(:)   |none          |fraction of plant biomass that is nitrogen
!!    pltfr_p(:)   |none          |fraction of plant biomass that is phosphorus
!!    sol_bd(:,:)  |Mg/m**3       |bulk density of the soil
!!    sol_fon(:,:) |kg N/ha       |amount of nitrogen stored in the fresh
!!                                |organic (residue) pool
!!    sol_fop(:,:) |kg P/ha       |amount of phosphorus stored in the fresh
!!                                |organic (residue) pool
!!    sol_nh3(:,:) |kg N/ha       |amount of nitrogen stored in the ammonium
!!                                |pool in soil layer
!!    sol_no3(:,:) |kg N/ha       |amount of nitrogen stored in the nitrate pool
!!                                |in soil layer
!!    sol_rsd(:,:) |kg/ha         |amount of organic matter in the soil
!!                                |classified as residue
!!    sol_solp(:,:)|kg P/ha       |amount of phosohorus stored in solution
!!    sol_z(:,:)   |mm            |depth to bottom of soil layer
!!    manure_kg(:) |(kg/ha)/day   |dry weight of manure deposited on HRU
!!                                |daily
!!    wshd_fminp   |kg P/ha       |average annual amount of mineral P applied
!!                                |in watershed
!!    wshd_fnh3    |kg N/ha       |average annual amount of NH3-N applied in
!!                                |watershed
!!    wshd_fno3    |kg N/ha       |average annual amount of NO3-N applied in
!!                                |watershed
!!    wshd_orgn    |kg N/ha       |average annual amount of organic N applied
!!                                |in watershed
!!    wshd_orgp    |kg P/ha       |average annual amount of organic P applied
!!                                |in watershed
!!    wshd_ftotn   |kg N/ha       |average annual amount of N (mineral &
!!                                |organic) applied in watershed
!!    wshd_ftotp   |kg P/ha       |average annual amount of P (mineral &
!!                                |organic) applied in watershed
!!    yldkg(:,:,:) |kg/ha         |yield (dry weight) by crop type in the HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bactlp_plt(:)|# cfu/m^2    |less persistent bacteria on foliage
!!    bactlpq(:)  |# cfu/m^2     |less persistent bacteria in soil solution
!!    bactlps(:)  |# cfu/m^2     |less persistent bacteria attached to soil
!!                               |particles
!!    bactp_plt(:)|# cfu/m^2     |persistent bacteria on foliage
!!    bactpq(:)   |# cfu/m^2     |persistent bacteria in soil solution
!!    bactps(:)   |# cfu/m^2     |persistent bacteria attached to soil particles
!!    bio_ms(:)   |kg/ha         |land cover/crop biomass (dry weight)
!!    grazn       |kg N/ha       |total amount of nitrogen applied to soil
!!                               |during grazing in HRU on day
!!    grazp       |kg P/ha       |total amount of phosphorus applied to soil
!!                               |during grazing in HRU on day
!!    igrz(:)     |none          |grazing flag for HRU:
!!                               |0 HRU currently not grazed
!!                               |1 HRU currently grazed
!!    laiday(:)   |m**2/m**2     |leaf area index
!!    ndeat(:)    |days          |number of days HRU has been grazed
!!    ngr(:)      |none          |sequence number of grazing operation
!!                               |within the year
!!    phuacc(:)   |none          |fraction of plant heat units accumulated
!!    plantn(:)   |kg N/ha       |amount of nitrogen in plant
!!    plantp(:)   |kg P/ha       |amount of phosphorus in plant
!!    sol_fon(:,:)|kg N/ha       |amount of nitrogen stored in the fresh
!!                               |organic (residue) pool
!!    sol_fop(:,:)|kg P/ha       |amount of phosphorus stored in the fresh
!!                               |organic (residue) pool
!!    sol_nh3(:,:)|kg N/ha       |amount of nitrogen stored in the ammonium
!!                               |pool in soil layer
!!    sol_no3(:,:)|kg N/ha       |amount of nitrogen stored in the nitrate pool
!!                               |in soil layer
!!    sol_rsd(:,:)|kg/ha         |amount of organic matter in the soil
!!                               |classified as residue
!!    sol_solp(:,:)|kg P/ha      |amount of phosohorus stored in solution
!!    wshd_fminp  |kg P/ha       |average annual amount of mineral P applied
!!                               |in watershed
!!    wshd_fnh3   |kg N/ha       |average annual amount of NH3-N applied in
!!                               |watershed
!!    wshd_fno3   |kg N/ha       |average annual amount of NO3-N applied in
!!                               |watershed
!!    wshd_orgn   |kg N/ha       |average annual amount of organic N applied
!!                               |in watershed
!!    wshd_orgp   |kg P/ha       |average annual amount of organic P applied
!!                               |in watershed
!!    wshd_ftotn  |kg N/ha       |average annual amount of N (mineral &
!!                               |organic) applied in watershed
!!    wshd_ftotp  |kg P/ha       |average annual amount of P (mineral &
!!                               |organic) applied in watershed
!!    yldkg(:,:,:)|kg/ha         |yield (dry weight) by crop type in the HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    dmi         |kg/ha         |biomass in HRU prior to grazing
!!    dmii        |kg/ha         |biomass prior to trampling
!!    frt_t       |
!!    gc          |
!!    gc1         |
!!    it          |none          |manure/fertilizer id number from fert.dat
!!    j           |none          |HRU number
!!    l           |none          |number of soil layer that manure is applied
!!    swf         |
!!    xx          |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Max
!!    SWAT: Erfc

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j, l, it
      real*8 :: dmi, dmii, gc, gc1, swf, frt_t, xx
      real*8 :: LMF, LSF

      j = 0
      j = ihru

!! graze only if adequate biomass in HRU
      if (bio_ms(j) > bio_min(j)) then

        !! determine new biomass in HRU
        dmi = 0.
        dmi = bio_ms(j)
        bio_ms(j) = bio_ms(j) - bio_eat(j)
        if (bio_ms(j) < bio_min(j)) bio_ms(j) = bio_min(j)

        !!add by zhang
        !!=================
        if (cswat == 2) then
            emitc_d(j) = emitc_d(j) + dmi - bio_ms(j)
        end if
        !!add by zhang
        !!=================

        !! adjust nutrient content of biomass
        plantn(j) = plantn(j) - (dmi - bio_ms(j)) * pltfr_n(j)
        plantp(j) = plantp(j) - (dmi - bio_ms(j)) * pltfr_p(j)
        if (plantn(j) < 0.) plantn(j) = 0.
        if (plantp(j) < 0.) plantp(j) = 0.

        !! remove trampled biomass and add to residue
        dmii = 0.
        dmii = bio_ms(j)
        bio_ms(j) = bio_ms(j) - bio_trmp(j)
        if (bio_ms(j) < bio_min(j))  then
          sol_rsd(1,j) = sol_rsd(1,j) + dmii - bio_min(j)
          bio_ms(j) = bio_min(j)
            !!add by zhang
            !!=================
            if (cswat == 2) then
                rsdc_d(j) = rsdc_d(j) + dmii - bio_ms(j)
            end if
            !!add by zhang
            !!=================
        else
          sol_rsd(1,j) = sol_rsd(1,j) + bio_trmp(j)
            !!add by zhang
            !!=================
            if (cswat == 2) then
                rsdc_d(j) = rsdc_d(j) + bio_trmp(j)
            end if
            !!add by zhang
            !!=================
        endif
        sol_rsd(1,j) = Max(sol_rsd(1,j),0.)
        bio_ms(j) = Max(bio_ms(j),0.)

        !! adjust nutrient content of residue and biomass for
        !! trampling
        plantn(j) = plantn(j) - (dmii - bio_ms(j)) * pltfr_n(j)
        plantp(j) = plantp(j) - (dmii - bio_ms(j)) * pltfr_p(j)
        if (plantn(j) < 0.) plantn(j) = 0.
        if (plantp(j) < 0.) plantp(j) = 0.
        if (dmii - bio_ms(j) > 0.) then
          sol_fon(1,j) = (dmii - bio_ms(j)) * pltfr_n(j) + sol_fon(1,j)

            !!insert new biomss by zhang
            !!===========================
            if (cswat == 2) then
                  !!all the lignin from STD is assigned to LSL,
	            !!add STDL calculation
	          !!
	          !sol_LSL(k,ihru) = sol_STDL(k,ihru)
	          !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK))
	          ! 52  BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY
                ! 53  BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY
                !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10
                !SUBROUTINE ASCRV(X1,X2,X3,X4)
                !EPIC0810
                !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS.
                !USE PARM
                !XX=LOG(X3/X1-X3)
                !X2=(XX-LOG(X4/X2-X4))/(X4-X3)
                !X1=XX+X3*X2
                !RETURN
                !END
                !HUI(JJK)=HU(JJK)/XPHU

                BLG1 = 0.01/0.10
                BLG2 = 0.99
                BLG3 = 0.10
                XXX = log(0.5/BLG1-0.5)
                BLG2 = (XXX -log(1./BLG2-1.))/(1.-0.5)
                BLG1 = XXX + 0.5*BLG2
                CLG=BLG3*phuacc(j)/(phuacc(j)+
     &              EXP(BLG1-BLG2*phuacc(j)))

	          !if (k == 1) then
		        sf = 0.05
	          !else
		        !sf = 0.1
	          !end if

               !kg/ha
	          sol_min_n = 0.
	          sol_min_n = (sol_no3(1,j)+sol_nh3(1,j))

	          resnew = (dmii - bio_ms(j))
	          resnew_n = (dmii - bio_ms(j)) * pltfr_n(j)
        	    resnew_ne = resnew_n + sf * sol_min_n
        	        !Not sure 1000 should be here or not!
        	    !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5))
        	    RLN = (resnew * CLG/(resnew_n+1.E-5))
        	    RLR = MIN(.8, resnew * CLG/1000/(resnew/1000+1.E-5))

        	    LMF = 0.85 - 0.018 * RLN
        	    if (LMF <0.01) then
        	        LMF = 0.01
        	    else
        	        if (LMF >0.7) then
        	            LMF = 0.7
        	        end if
        	    end if
	          !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then
		        !    LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5))
	          !else
		        !    LMF = 0.
	          !end if

	          LSF =  1 - LMF

	          sol_LM(1,j) = sol_LM(1,j) + LMF * resnew
	          sol_LS(1,j) = sol_LS(1,j) + LSF * resnew

	          !here a simplified assumption of 0.5 LSL
	          !LSLF = 0.0
	          !LSLF = CLG

	          sol_LSL(1,j) = sol_LSL(1,j) + RLR*resnew
	          sol_LSC(1,j) = sol_LSC(1,j) + 0.42*LSF * resnew

	          sol_LSLC(1,j) = sol_LSLC(1,j) + RLR*0.42* resnew
	          sol_LSLNC(1,j) = sol_LSC(1,j) - sol_LSLC(1,j)

                !X3 = MIN(X6,0.42*LSF * resnew/150)

	          if (resnew_ne >= (0.42 * LSF * resnew /150)) then
		         sol_LSN(1,j) = sol_LSN(1,j) + 0.42 * LSF * resnew / 150
		         sol_LMN(1,j) = sol_LMN(1,j) + resnew_ne -
     &                         (0.42 * LSF * resnew / 150) + 1.E-25
	          else
		         sol_LSN(1,j) = sol_LSN(1,j) + resnew_ne
		         sol_LMN(1,j) = sol_LMN(1,j) + 1.E-25
	          end if

	          !LSNF = sol_LSN(1,j)/(sol_LS(1,j)+1.E-5)

	          sol_LMC(1,j) = sol_LMC(1,j) + 0.42 * LMF * resnew
	          !LMNF = sol_LMN(1,j)/(sol_LM(1,j) + 1.E-5)

                !update no3 and nh3 in soil
                sol_no3(1,j) = sol_no3(1,j) * (1-sf)
                sol_nh3(1,j) = sol_nh3(1,j) * (1-sf)
            end if
            !!insert new biomss by zhang
            !!===========================

          sol_fop(1,j) = (dmii - bio_ms(j)) * pltfr_p(j) + sol_fop(1,j)
        end if

        !! apply manure
        it = 0
        it = manure_id(j)
        if (manure_kg(j) > 0.) then
          l = 1

          if (cswat == 0) then

          sol_no3(l,j) = sol_no3(l,j) + manure_kg(j)               *
     &                 (1. - fnh3n(it)) * fminn(it)
          sol_fon(l,j) = sol_fon(l,j) + manure_kg(j)               *
     &                 forgn(it)
          sol_nh3(l,j) = sol_nh3(l,j) + manure_kg(j)               *
     &                 fnh3n(it) * fminn(it)
          sol_solp(l,j) = sol_solp(l,j) + manure_kg(j)             *
     &                 fminp(it)
          sol_fop(l,j) = sol_fop(l,j) + manure_kg(j)               *
     &                 forgp(it)
          end if
          if (cswat == 1) then
          sol_no3(l,j) = sol_no3(l,j) + manure_kg(j)               *
     &                 (1. - fnh3n(it)) * fminn(it)
          sol_mn(l,j) = sol_mn(l,j) + manure_kg(j)                 *
     &                 forgn(it)
          sol_nh3(l,j) = sol_nh3(l,j) + manure_kg(j)               *
     &                 fnh3n(it) * fminn(it)
          sol_solp(l,j) = sol_solp(l,j) + manure_kg(j)             *
     &                 fminp(it)
          sol_mp(l,j) = sol_mp(l,j) + manure_kg(j)               *
     &                 forgp(it)
          sol_mc(l,j) = sol_mc(l,j) + manure_kg(j)               *
     &                 forgn(it) * 10.
          end if

          !!By Zhang for C/N cycling
          !!===============================
          if (cswat == 2) then
          sol_no3(l,j) = sol_no3(l,j) + manure_kg(j) *
     &                 (1. - fnh3n(it)) * fminn(it)
          !sol_fon(l,j) = sol_fon(l,j) + manure_kg(j) *
     &    !             forgn(it)
          orgc_f = 0.35
          X1 = manure_kg(j)
          X8 = X1 * orgc_f
          RLN = .175 *(orgc_f)/(fminn(it) + forgn(it) + 1.e-5)
          X10 = .85-.018*RLN
          if (X10<0.01) then
            X10 = 0.01
          else
            if (X10 > .7) then
                X10 = .7
            end if
          end if
          XX = X8 * X10
          sol_LMC(l,j) = sol_LMC(l,j) + XX
          YY = manure_kg(j) * X10
          sol_LM(l,j) = sol_LM(l,j) + YY
          ZZ = manure_kg(j) *forgn(it) * X10
          sol_LMN(l,j) = sol_LMN(l,j) + ZZ
          sol_LSN(l,j) = sol_LSN(l,j) + manure_kg(j)
     &                      *forgn(it) -ZZ
          XZ = manure_kg(j) *orgc_f-XX
          sol_LSC(l,j) = sol_LSC(l,j) + XZ
          sol_LSLC(l,j) = sol_LSLC(l,j) + XZ * .175
          sol_LSLNC(l,j) = sol_LSLNC(l,j) + XZ * (1.-.175)
          YZ = manure_kg(j) - YY
          sol_LS(l,j) = sol_LS(l,j) + YZ
          sol_LSL(l,j) = sol_LSL(l,j) + YZ*.175

          sol_fon(l,j) = sol_LMN(l,j) + sol_LSN(l,j)

          sol_nh3(l,j) = sol_nh3(l,j) + manure_kg(j) *
     &                 fnh3n(it) * fminn(it)
          sol_solp(l,j) = sol_solp(l,j) + manure_kg(j) *
     &                 fminp(it)
          sol_fop(l,j) = sol_fop(l,j) + manure_kg(j) *
     &                 forgp(it)

          end if
          !!By Zhang for C/N cycling
          !!===============================
!! add bacteria - #cfu/g * t(manure)/ha * 1.e6 g/t * ha/10,000 m^2 = 100.
!! calculate ground cover
          gc = 0.
          gc = (1.99532 - Erfc(1.333 * laiday(j) - 2.)) / 2.1
          if (gc < 0.) gc = 0.

          gc1 = 0.
          gc1 = 1. - gc

          swf = .15

          frt_t = 0.
          frt_t = bact_swf * manure_kg(j) / 1000.

          bactp_plt(j) = gc * bactpdb(it) * frt_t * 100. + bactp_plt(j)
          bactlp_plt(j) = gc * bactlpdb(it) * frt_t * 100.+bactlp_plt(j)

          bactpq(j) = gc1 * bactpdb(it)  * frt_t * 100. + bactpq(j)
          bactpq(j) = bactkddb(it) * bactpq(j)

          bactps(j) = gc1 * bactpdb(it) * frt_t * 100. + bactps(j)
          bactps(j) = (1. - bactkddb(it)) * bactps(j)

          bactlpq(j) = gc1 * bactlpdb(it) * frt_t * 100. + bactlpq(j)
          bactlpq(j) = bactkddb(it) * bactlpq(j)

          bactlps(j) = gc1 * bactlpdb(it) * frt_t * 100. + bactlps(j)
          bactlps(j) = (1. - bactkddb(it)) * bactlps(j)

        endif

        !! reset leaf area index and fraction of growing season
        if (dmi > 1.) then
          laiday(j) = laiday(j) * bio_ms(j) / dmi
          phuacc(j) = phuacc(j) * bio_ms(j) / dmi
        else
          laiday(j) = 0.05
          phuacc(j) = 0.
        endif

        !! summary calculations
        !! I do not understand these summary calculations Armen March 2009
        grazn = grazn + manure_kg(j)               *
     &               (fminn(it) + forgn(it))
        grazp = grazp + manure_kg(j)               *
     &               (fminp(it) + forgp(it))
        tgrazn(j) = tgrazn(j) + grazn
        tgrazp(j) = tgrazp(j) + grazp

        if (curyr > nyskip) then
          wshd_ftotn = wshd_ftotn + manure_kg(j)               *
     &               hru_dafr(j) * (fminn(it) + forgn(it))
          wshd_forgn = wshd_forgn + manure_kg(j)               *
     &               hru_dafr(j) * forgn(it)
          wshd_fno3 = wshd_fno3 + manure_kg(j)               *
     &               hru_dafr(j) * fminn(it) * (1. - fnh3n(it))
          wshd_fnh3 = wshd_fnh3 + manure_kg(j)               *
     &               hru_dafr(j) * fminn(it) * fnh3n(it)
          wshd_ftotp = wshd_ftotp + manure_kg(j)               *
     &               hru_dafr(j) * (fminp(it) + forgp(it))
          wshd_fminp = wshd_fminp + manure_kg(j)               *
     &               hru_dafr(j) * fminp(it)
          wshd_forgp = wshd_forgp + manure_kg(j)               *
     &               hru_dafr(j) * forgp(it)
  !       yldkg(nro(j),1,j) = yldkg(nro(j),1,j) + (dmi - bio_ms(j))
      yldkg(icr(j),j)=yldkg(icr(j),j) + (dmi - bio_ms(j))
        end if
      end if

!! check to set if grazing period is over
      if (ndeat(j) == grz_days(j)) then
        igrz(j) = 0
        ndeat(j) = 0
        ngr(j) = ngr(j) + 1
      end if

      return
      end


MODULE bdydyn
  USE oce
  USE dom_oce
  USE bdy_oce
  USE bdydyn2d
  USE bdydyn3d
  USE lbclnk
  USE in_out_manager
  USE domvvl
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: bdy_dyn
  CONTAINS
  SUBROUTINE bdy_dyn(kt, dyn3d_only)
    INTEGER, INTENT(IN) :: kt
    LOGICAL, INTENT(IN), OPTIONAL :: dyn3d_only
    INTEGER :: jk, ii, ij, ib_bdy, ib, igrd
    LOGICAL :: ll_dyn2d, ll_dyn3d, ll_orlanski
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: pua2d, pva2d
    ll_dyn2d = .TRUE.
    ll_dyn3d = .TRUE.
    IF (PRESENT(dyn3d_only)) THEN
      IF (dyn3d_only) ll_dyn2d = .FALSE.
    END IF
    ll_orlanski = .FALSE.
    DO ib_bdy = 1, nb_bdy
      IF (cn_dyn2d(ib_bdy) == 'orlanski' .OR. cn_dyn2d(ib_bdy) == 'orlanski_npo' .OR. cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo') ll_orlanski = .TRUE.
    END DO
    !$ACC KERNELS
    pua2d(:, :) = 0._wp
    pva2d(:, :) = 0._wp
    DO jk = 1, jpkm1
      pua2d(:, :) = pua2d(:, :) + e3u_a(:, :, jk) * ua(:, :, jk) * umask(:, :, jk)
      pva2d(:, :) = pva2d(:, :) + e3v_a(:, :, jk) * va(:, :, jk) * vmask(:, :, jk)
    END DO
    pua2d(:, :) = pua2d(:, :) * r1_hu_a(:, :)
    pva2d(:, :) = pva2d(:, :) * r1_hv_a(:, :)
    DO jk = 1, jpkm1
      ua(:, :, jk) = (ua(:, :, jk) - pua2d(:, :)) * umask(:, :, jk)
      va(:, :, jk) = (va(:, :, jk) - pva2d(:, :)) * vmask(:, :, jk)
    END DO
    !$ACC END KERNELS
    IF (ll_orlanski) THEN
      !$ACC KERNELS
      DO jk = 1, jpkm1
        ub(:, :, jk) = (ub(:, :, jk) - ub_b(:, :)) * umask(:, :, jk)
        vb(:, :, jk) = (vb(:, :, jk) - vb_b(:, :)) * vmask(:, :, jk)
      END DO
      !$ACC END KERNELS
    END IF
    IF (ll_dyn2d) CALL bdy_dyn2d(kt, pua2d, pva2d, ub_b, vb_b, r1_hu_a(:, :), r1_hv_a(:, :), ssha)
    IF (ll_dyn3d) CALL bdy_dyn3d(kt)
    !$ACC KERNELS
    DO jk = 1, jpkm1
      ua(:, :, jk) = (ua(:, :, jk) + pua2d(:, :)) * umask(:, :, jk)
      va(:, :, jk) = (va(:, :, jk) + pva2d(:, :)) * vmask(:, :, jk)
    END DO
    !$ACC END KERNELS
    IF (ll_orlanski) THEN
      !$ACC KERNELS
      DO jk = 1, jpkm1
        ub(:, :, jk) = (ub(:, :, jk) + ub_b(:, :)) * umask(:, :, jk)
        vb(:, :, jk) = (vb(:, :, jk) + vb_b(:, :)) * vmask(:, :, jk)
      END DO
      !$ACC END KERNELS
    END IF
  END SUBROUTINE bdy_dyn
END MODULE bdydyn


! MinimalDX version 0.1.4 (https://www.github.com/dmey/minimal-dx).
! Copyright 2018-2020 D. Meyer and R. Raustad. Licensed under MIT.

module MinimalDXCoolingDriver
  !+ Contains a simplified EnergyPlus subroutine for simulating the performance of a DX cooling coil.

  implicit none

  private
  public SimMinimalDXCooling

  contains
  subroutine SimMinimalDXCooling(OutdoorTDryBulb, OutdoorHumRatio, OutdoorPressure,                & ! I
                                 InletTDryBulb, InletHumRatio,                                     & ! I
                                 RatedCOP, RatedTotCap, SensibleCoolingLoad, RatedAirMassFlowRate, & ! I
                                 COP, TotalCoolingCapacity,                                        & ! O
                                 OutletTemperature, OutletHumRatio,                                & ! O
                                 ElecCoolingPower, LatCoolingEnergyRate,                           & ! O
                                 TotalCoolingEnergyRate, TotalSensibleHeatOut)                       ! O

    !+ Simplified EnergyPlus subroutine for calculating the performance of a DX cooling coil.
    !+ This is the subroutine to call from your program.

    use MinimalDXCooling, only: CalcMinimalDXCooling

    ! Subroutine arguments
    real, intent(in)    :: OutdoorTDryBulb
        !+ Outdoor dry bulb air temperature `[°C]`
    real, intent(in)    :: OutdoorHumRatio
        !+ Outdoor air humidity ratio `[kgH₂O kgAIR⁻¹]`
    real, intent(in)    :: OutdoorPressure
        !+ Outdoor barometric pressure `[Pa]`
    real, intent(in)    :: InletTDryBulb
        !+ Indoor (inlet) dry bulb air temperature `[°C]`
    real, intent(in)    :: InletHumRatio
        !+ Indoor (inlet) air humidity ratio `[kgH₂O kgAIR⁻¹]`
    real, intent(in)    :: RatedCOP
        !+ Rated Coefficient Of Performance (COP) `[1]`
    real, intent(in)    :: RatedTotCap
        !+ Rated (total) system capacity `[W]`
    real, intent(in)    :: SensibleCoolingLoad
        !+ Building sensible load to be met `[W]`
    real, intent(in)    :: RatedAirMassFlowRate
        !+ rated air mass flow rate `[kg s⁻¹]`
    real, intent(out)   :: COP
    !+ Actual (calculated) Coefficient Of Performance (COP) `[1]`
    real, intent(out)   :: TotalCoolingCapacity
        !+ Actual (calculated) total system capacity `[W]`
    real, intent(out)   :: OutletTemperature
        !+ Actual (calculated) outlet air dry bulb temperature existing the cooling coil `[°C]`
    real, intent(out)   :: OutletHumRatio
        !+ Actual (calculated) outlet air humidity ratio existing the cooling coil `[kgH₂O kgAIR⁻¹]`
    real, intent(out)   :: ElecCoolingPower
        !+ Calculated electrical power consumed by the DX unit `[W]`
    real, intent(out)   :: LatCoolingEnergyRate
        ! Total latent cooling energy rate extracted by the coil from the indoor environment `[J kg⁻¹]`
    real, intent(out)   :: TotalCoolingEnergyRate
        !+ Total cooling power of the DX unit (energy rate extracted by DX unit from the indoor environment) `[W]`
    real, intent(out)   :: TotalSensibleHeatOut
        !+ Total power rejected by the evaporator into the outdoor environment
        !+ i.e. TotalCoolingEnergyRate + ElecCoolingPower `[W]`

    ! Local variables
    real :: PartLoadRatio
    real :: SensCoolingEnergyRate
        !+ Sensible cooling power used to calculate the PLR. This is the maximum amount of sensible heat rate that the coil
        !+ is capable of extracting from the indoor environment for the specified conditions. `[W]`

    ! Get SensibleCoolingLoad and SensCoolingEnergyRates to calculate actual PartLoadRatio
    PartLoadRatio = 1.

    call CalcMinimalDXCooling(OutdoorTDryBulb, OutdoorHumRatio, OutdoorPressure,                & ! I
                              InletTDryBulb, InletHumRatio,                                     & ! I
                              RatedCOP, RatedTotCap, PartLoadRatio, RatedAirMassFlowRate,       & ! I
                              OutletTemperature, OutletHumRatio,                                & ! O
                              ElecCoolingPower, SensCoolingEnergyRate, LatCoolingEnergyRate,    & ! O
                              TotalCoolingEnergyRate, TotalSensibleHeatOut)

    ! Calculate PartLoadRatio from previous call
    PartLoadRatio = SensibleCoolingLoad / SensCoolingEnergyRate

    ! Keep PartLoadRatio  bounded between 0 and 1
    if ( PartLoadRatio < 0. ) PartLoadRatio = 0.
    if ( PartLoadRatio > 1. ) PartLoadRatio = 1.

    ! Call CalcDoe2DXCoil again with correct part load ratio
    call CalcMinimalDXCooling(OutdoorTDryBulb, OutdoorHumRatio, OutdoorPressure,                & ! I
                              InletTDryBulb, InletHumRatio,                                     & ! I
                              RatedCOP, RatedTotCap, PartLoadRatio, RatedAirMassFlowRate,       & ! I
                              OutletTemperature, OutletHumRatio,                                & ! O
                              ElecCoolingPower, SensCoolingEnergyRate, LatCoolingEnergyRate,    & ! O
                              TotalCoolingEnergyRate, TotalSensibleHeatOut)

    COP = TotalCoolingEnergyRate / ElecCoolingPower
    TotalCoolingCapacity = TotalCoolingEnergyRate / PartLoadRatio

  end subroutine SimMinimalDXCooling
end module MinimalDXCoolingDriver


module pf_my_stepper
  use encap
  use pf_mod_rkstepper
  use pfasst
  use pf_my_level
  use probin
  use pf_my_sweeper
  implicit none

  !>  extend the stepper type with stuff we need to compute rhs
  type, extends(pf_ark_stepper_t) :: my_stepper_t
   type(c_ptr) :: c_hypre_solver_ptr = c_null_ptr
   contains

     procedure :: f_eval => f_eval_stepper    !  Computes the explicit rhs terms
     procedure :: f_comp => f_comp_stepper    !  Does implicit solves

     procedure :: initialize => initialize_stepper !  Overwrites stepper initialize_stepper
     procedure :: destroy => destroy_stepper    !  Overwrites stepper destroy_stepper

     procedure :: get_nrows => stepper_get_nrows
     procedure :: get_extent => stepper_get_extent

  end type my_stepper_t
contains

  !>  Routine to set up stepper variables and operators
  subroutine initialize_stepper(this, pf,level_index)
    class(my_stepper_t), intent(inout) :: this
    type(pf_pfasst_t), intent(inout),target :: pf
    integer, intent(in) :: level_index
    integer :: nx, comm_color, space_dim, max_space_v_cycles, spacial_coarsen_flag

    if (solver_type .eq. 2) then
       this%nsteps=nsteps_rk(level_index)
    end if

    call this%ark_initialize(pf,level_index)

    if (ark_stat .eq. 0) then
       this%explicit=.TRUE.
       this%implicit=.FALSE.
    elseif (ark_stat .eq. 1) then
       this%implicit=.TRUE.
       this%explicit=.FALSE.
    else
       this%implicit=.TRUE.
       this%explicit=.TRUE.
    end if

    ! Space variables
    nx = pf%levels(level_index)%lev_shape(1)
    comm_color = pf%levels(level_index)%lev_shape(2)
    space_dim = pf%levels(level_index)%lev_shape(3)
    max_space_v_cycles = pf%levels(level_index)%lev_shape(4)
    spacial_coarsen_flag = pf%levels(level_index)%lev_shape(10)

    !> Call the Hypre solver initialization
    call HypreSolverInit(this%c_hypre_solver_ptr, &
                         level_index, &
                         nx, &
                         comm_color, &
                         space_dim, &
                         max_space_v_cycles, &
                         pf%nlevels, &
                         spacial_coarsen_flag)
  end subroutine initialize_stepper

  !>  destroy_stepper the stepper type
  subroutine destroy_stepper(this, pf,level_index)
    class(my_stepper_t), intent(inout) :: this
    type(pf_pfasst_t), intent(inout), target :: pf
    integer, intent(in) :: level_index

    !> Destroy Hypre solver variables
    call HypreSolverDestroy(this%c_hypre_solver_ptr, level_index)

    !>  Call the stepper destroy_stepper
    call this%ark_destroy(pf,level_index)
  end subroutine destroy_stepper

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! These routines must be provided for the stepper
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Evaluate the explicit function at y, t.
  subroutine f_eval_stepper(this, y, t, level_index, f, piece)
    class(my_stepper_t), intent(inout) :: this
    class(pf_encap_t),   intent(in   ) :: y
    class(pf_encap_t),   intent(inout) :: f
    real(pfdp),          intent(in   ) :: t
    integer,             intent(in   ) :: level_index
    integer,             intent(in   ) :: piece
    real(pfdp) :: val

    class(hypre_vector_encap), pointer :: y_encap, f_encap

    y_encap => cast_as_hypre_vector(y)
    f_encap => cast_as_hypre_vector(f)

    !> Call Hypre to do the f_eval
    call HypreSolverFEval(this%c_hypre_solver_ptr, y_encap%c_hypre_vector_ptr, t, level_index, f_encap%c_hypre_vector_ptr, piece)
  end subroutine f_eval_stepper

  ! Solve for y and return f2 also.
  subroutine f_comp_stepper(this, y, t, dtq, rhs, level_index, f, piece)
    class(my_stepper_t), intent(inout) :: this
    class(pf_encap_t),   intent(inout) :: y
    real(pfdp),          intent(in   ) :: t
    real(pfdp),          intent(in   ) :: dtq
    class(pf_encap_t),   intent(in   ) :: rhs
    integer,             intent(in   ) :: level_index
    class(pf_encap_t),   intent(inout) :: f
    integer,             intent(in   ) :: piece

    class(hypre_vector_encap), pointer :: y_encap, f_encap, rhs_encap
    real(pfdp) :: val

    y_encap => cast_as_hypre_vector(y)
    f_encap => cast_as_hypre_vector(f)
    rhs_encap => cast_as_hypre_vector(rhs)

    !> Call Hypre to do the f_comp
    call HypreSolverFComp(this%c_hypre_solver_ptr, &
                          y_encap%c_hypre_vector_ptr, &
                          t, &
                          dtq, &
                          rhs_encap%c_hypre_vector_ptr, &
                          level_index, &
                          f_encap%c_hypre_vector_ptr, &
                          piece)
  end subroutine f_comp_stepper

  subroutine stepper_hypre_set_level_data(pf)
     type(pf_pfasst_t), intent(inout) :: pf
     type(my_stepper_t) :: s_finest, s
     integer :: l

     s_finest = cast_as_my_stepper_t(pf%levels(pf%nlevels)%ulevel%stepper)

     do l = 1, pf%nlevels-1
        s = cast_as_my_stepper_t(pf%levels(l)%ulevel%stepper)
        call HypreSolverSetLevelData(s%c_hypre_solver_ptr, s_finest%c_hypre_solver_ptr, l);
     end do
  end subroutine stepper_hypre_set_level_data

  function stepper_get_nrows(this, level_index) result(nrows)
     class(my_stepper_t), intent(inout) :: this
     integer, intent(in) :: level_index
     integer :: nrows
     nrows = HypreSolverGetNumRowsLevel(this%c_hypre_solver_ptr, level_index)
  end function

  function stepper_get_extent(this, level_index, i) result(extent)
     class(my_stepper_t), intent(inout) :: this
     integer, intent(in) :: level_index, i
     integer :: extent
     extent = HypreSolverGetExtentLevel(this%c_hypre_solver_ptr, level_index, i)
  end function

  function cast_as_my_stepper_t(pf_stepper_t_polymorph) result(my_stepper_t_obj)
    class(pf_stepper_t), intent(in), target :: pf_stepper_t_polymorph
    type(my_stepper_t), pointer :: my_stepper_t_obj

    select type(pf_stepper_t_polymorph)
    type is (my_stepper_t)
       my_stepper_t_obj => pf_stepper_t_polymorph
    end select
  end function cast_as_my_stepper_t
end module pf_my_stepper


C Copyright(C) 2011-2017 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C * Redistributions of source code must retain the above copyright
C    notice, this list of conditions and the following disclaimer.
C
C * Redistributions in binary form must reproduce the above
C   copyright notice, this list of conditions and the following
C   disclaimer in the documentation and/or other materials provided
C   with the distribution.
C
C * Neither the name of NTESS nor the names of its
C   contributors may be used to endorse or promote products derived
C   from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C=======================================================================
      SUBROUTINE EXPARC (XN, YN, XN3, YN3, ZN3, IXNP, NRNP, NPCEN,
     &   SINANG, COSANG)
C=======================================================================

C   --*** EXPARC *** (GEN3D) Calculate 3D coordinates
C   --   Written by Amy Gilkey - revised 05/09/88
C   --   Modified by Greg Sjaardema - 02/06/89
C   --       Added Warp Function
C   --       Added Gradient to Rotations (not for center blocks)
C   --
C   --NEWXYZ calculates the coordinate array for the 3D database.
C   --
C   --Parameters:
C   --   XN, YN - IN - the 2D coordinates, destroyed
C   --   XN3, YN3, ZN3 - OUT - the 3D coordinates
C   --   IXNP - IN - the new index for each node
C   --   NRNP - IN - the number of new nodes generated for each node
C   --   NPCEN - IN - the node numbers of the center nodes by column and row
C   --   SINANG, COSANG - SCRATCH - size = NNREPL, holds sin and cos of
C   --      angles for rotations
C   --
C   --Common Variables:
C   --   Uses NDIM, NUMNP of /DBNUMS/
C   --   Uses NDIM3, NUMNP3 of /DBNUM3/
C   --   Uses DOTRAN, NNREPL, DIM3, NRTRAN, D3TRAN, ZGRAD,
C   --      CENTER, NUMCOL, NUMROW of /PARAMS/

      INCLUDE 'g3_dbnums.blk'
      INCLUDE 'g3_dbnum3.blk'
      INCLUDE 'g3_params.blk'

      REAL XN(NUMNP), YN(NUMNP),
     &   XN3(NUMNP3), YN3(NUMNP3), ZN3(NUMNP3)
      INTEGER IXNP(*), NRNP(*)
      INTEGER NPCEN(NUMCDM,*)
      REAL SINANG(NNREPL), COSANG(NNREPL)

      PI = ATAN2(0.0, -1.0)
C      --For rotations, change X and add Z so that they define pie-shaped
C      --regions around the Y axis

C   --Copy Y coordinate from original

         DO 520 INP = 1, NUMNP
            JNP0 = IXNP(INP) - 1
            DO 510 NR = 1, NRNP(INP)
               YN3(JNP0+NR) = YN(INP)
  510       CONTINUE
  520    CONTINUE

C ... Check minimum X coordinate to see if we will generate bad elements
         XMIN = XN(1)
         DO 5 INP = 2, NUMNP
           XMIN = MIN(XMIN, XN(INP))
 5       CONTINUE
         XMIN = XMIN - CENTER
         if (XMIN .LT. 0) THEN
           call prterr('WARNING',
     &       'Input mesh crosses over axis of rotation (Y). Negative '//
     &       'elements may be generated. Adjust ROTCEN or input mesh.')
         end if

C      --Subtract center, so rotation is around zero

      IF (CENTER .NE. 0.0) THEN
         DO 20 INP = 1, NUMNP
            XN(INP) = XN(INP) - CENTER
   20    CONTINUE
      END IF

C      --Get the coordinates for the non-center nodes

      IBLK = 0
      NXTNR = 1

      ZEND = 0.0
      DEGR = 0.0
    1    CONTINUE
         IBLK = IBLK + 1
         IF (NRTRAN(IBLK) .GT. 0) THEN
            ZBEG = ZEND
            ZEND = ZBEG + D3TRAN(IBLK) * PI / 180.
            DEGR = DEGR + D3TRAN(IBLK)
            if (DEGR .lt. 360.0) then
               nrot = nrtran(iblk)+1
            else
               nrot = nrtran(iblk)
            end if
            CALL INIGRD (-ZBEG, -ZEND, ZGRAD(IBLK),
     *         NRTRAN(IBLK), nrot, COSANG(NXTNR) )
            NXTNR = NXTNR + NRTRAN(IBLK)
            IF (IBLK .LT. MAXINT) GO TO 1
         END IF

         DO 30 NR = 1, NNREPL
            ANG = COSANG(NR)
            SINANG(NR) = SIN (ANG)
            COSANG(NR) = COS (ANG)
   30    CONTINUE

      DO 60 INP = 1, NUMNP
         IF (NRNP(INP) .EQ. NNREPL) THEN
            JNP = IXNP(INP)
            X = XN(INP)
            DO 50 NR = 1, NNREPL
               XN3(JNP) = X * COSANG(NR)
               ZN3(JNP) = X * SINANG(NR)
               JNP = JNP + 1
   50       CONTINUE
         END IF
   60 CONTINUE

C      --Add center of rotation

      IF (CENTER .NE. 0.0) THEN
         DO 180 JNP = 1, NUMNP3
            XN3(JNP) = XN3(JNP) + CENTER
  180    CONTINUE
      END IF
      RETURN
      END


  SUBROUTINE AERATE
  USE GLOBAL;USE MAIN; USE KINETIC; USE TRANS; USE SCREENC
  IMPLICIT NONE
  REAL, ALLOCATABLE, DIMENSION (:) ::  DZMULTA,SMASS,ATIMON,ATIMOFF,CUMDOMASS
  REAL, ALLOCATABLE, DIMENSION (:,:) ::  DZMULT
  INTEGER, ALLOCATABLE, DIMENSION (:) ::   IASEG,KTOPA,KBOTA,IPRB,KPRB
  REAL, ALLOCATABLE, DIMENSION (:) :: DOOFF,DOON
  REAL, ALLOCATABLE, DIMENSION (:) :: ACTUAL_MASS
  LOGICAL, ALLOCATABLE, DIMENSION (:) :: AERATEO2
  INTEGER NAER, NLAYERS, KTOP,KBOT
  CHARACTER(16) :: CONAER
  SAVE

  ALLOCATE(DZMULT(KMX,IMX))
   DZMULT=1.0
   OPEN(AERATEFN,FILE='W2_AERATE.NPT',STATUS='OLD')
   READ (AERATEFN,'(//I8,A16)')NAER,CONAER

     IF(NAER.EQ.0)NAER=1
     ALLOCATE(DZMULTA(NAER),IASEG(NAER),KTOPA(NAER),KBOTA(NAER),SMASS(NAER),ATIMON(NAER),ATIMOFF(NAER),DOOFF(NAER),DOON(NAER),IPRB(NAER),KPRB(NAER),ACTUAL_MASS(NAER),AERATEO2(NAER),CUMDOMASS(NAER))
     DZMULTA=0.0; ACTUAL_MASS=0.0; CUMDOMASS=0.0
     READ(AERATEFN,1013)
1013 FORMAT(/)
      DO I=1,NAER
        READ(AERATEFN,'(I8,I8,I8,F8.0,F8.0,F8.0,3F8.0,2I8)')IASEG(I),KTOPA(I),KBOTA(I),SMASS(I),ATIMON(I),ATIMOFF(I),DZMULTA(I),DOOFF(I),DOON(I),IPRB(I),KPRB(I)
      END DO

	CLOSE(AERATEFN)

IF(RESTART_IN)THEN
  OPEN(AERATEFN,FILE=CONAER,POSITION='APPEND')
        JDAY1=0.0
        REWIND (AERATEFN)
        READ   (AERATEFN,'(//)')
        DO WHILE (JDAY1 < JDAY)
          READ (AERATEFN,'(F9.0)',END=106) JDAY1
        END DO
        BACKSPACE (AERATEFN)
        106     JDAY1=0.0
ELSE
  OPEN(AERATEFN,FILE=CONAER,STATUS='UNKNOWN')
  WRITE(AERATEFN,'(A,I3,A)')'OUTPUT FILE FOR AERATION INPUT WITH',NAER,' INPUT(S).'
  WRITE(AERATEFN,'(A114)')'JDAY,INSTMASSRATE#1(KGO2/D),CUMMASS#1(KGO2),DOPROBE#1(MG/L),INSTMASSRATE#2(KGO2/D),CUMMASS#2(KGO2),DOPROBE#2(MG/L)'
ENDIF
  DZMULT=1.0  ! ALWAYS RESET MIXING COEFFICIENT FOR AERATION SW IPC 2/01/01
 RETURN

 ENTRY DZAERATE   ! FROM W2_ MAIN CODE
    DO I=1,NAER
    DZ(KTOPA(I):KBOTA(I),IASEG(I))=DZ(KTOPA(I):KBOTA(I),IASEG(I))*DZMULT(KTOPA(I):KBOTA(I),IASEG(I))
    ENDDO
 RETURN

 ENTRY AERATEMASS   ! FROM WQ_CONSTITUENTS

! SECTION FOR HYPOLIMNETIC AERATION
 DZMULT=1.0   ! ALWAYS RESET TO 1.0 IN CASE NO AERATION
              DO II=1,NAER
                IF(JDAY.GE.ATIMON(II).AND.JDAY.LE.ATIMOFF(II))THEN

           ! FIND BRANCH AND WATERBODY FOR ISEG
                  DO JJB=1,NBR
                    IF(BR_INACTIVE(JJB))CYCLE  ! SW 6/12/2017
                    IF(IASEG(II).GE.US(JJB).AND.IASEG(II).LE.DS(JJB))THEN
                      EXIT
                    END IF
                  END DO

                  IF(JJB.EQ.JB)THEN   ! IF THIS BRANCH DOESN'T HAVE AERATION SKIP IT

                    KTOP=MAX(KTWB(JW),KTOPA(II))
                    KBOT=MIN(KB(IASEG(II)),KBOTA(II))

                    NLAYERS=KBOT-KTOP+1

                    AERATEO2(II)=.TRUE.

                    IF(O2(KPRB(II),IPRB(II)).GT.DOON(II).AND.O2(KPRB(II),IPRB(II)).GT.DOOFF(II))THEN
                      AERATEO2(II)=.FALSE.
                      ACTUAL_MASS(II)=0.0
                    END IF

                    IF(AERATEO2(II))THEN
                      ACTUAL_MASS(II)=SMASS(II)  ! SW 12/28/01
                      CUMDOMASS(II)=CUMDOMASS(II)+SMASS(II)*DLT/86400.
                      DO K=KTOP,KBOT

                        DZMULT(K,IASEG(II))=DZMULTA(II)   ! THIS MEANS THE INCREASE IN DZ IS LAGGED ONE TIME STEP
                        CSSB(K,IASEG(II),NDO)=CSSB(K,IASEG(II),NDO)+SMASS(II)/(86.4*REAL(NLAYERS))
! UNITS OF SMASS ARE IN KG/DAY
! TYPICAL UNITS OF CSSB: (MG/L)*(M3/S) TO OONVERT MULTIPLY BY (1KG/10^6MG)*(1000L/1M3)*(86400S/DAY)==86.4

                      END DO
                    END IF
                  END IF
                ELSE
                AERATEO2(II)=.FALSE.
                ACTUAL_MASS(II)=0.0
                END IF

              END DO

RETURN

ENTRY AERATEOUTPUT     ! FROM W2_MAIN CODE

        WRITE(AERATEFN,'(F9.3,<NAER>(1X,E12.3,1X,E12.3,1X,F8.3))')JDAY,(ACTUAL_MASS(II),CUMDOMASS(II),O2(KPRB(II),IPRB(II)),II=1,NAER)

RETURN
ENTRY DEALLOCATE_AERATE
DEALLOCATE(DZMULTA,IASEG,KTOPA,KBOTA,SMASS,ATIMON,ATIMOFF,DOOFF,DOON,IPRB,KPRB,ACTUAL_MASS,AERATEO2,CUMDOMASS)
DEALLOCATE(DZMULT)
CLOSE(AERATEFN)
RETURN
END


      SUBROUTINE WBLOT
C++
C
C WBLOT.F Version 3.4   "Reverse drizzling"
C
C It is based on ideas of Andy Fruchter and was coded by Richard Hook.
C
C This task uses coefficients held in a text file to define
C geometrical distortions.
C
C This code uses the F77/VOS for IRAF i/o.
C It may be compiled and linked using a command like:
C
C xc -p stsdas (-z) blot.f drutil.f x_blot.x <dir>libiraf77.a <dir>libiminterp.a
C
C Note that the optional -z switch (which tells IRAF to create a static
C executable which doesn't use the IRAF sharable library) may be
C necessary to avoid a virtual memory use limitations.
C
C History:
C
C Created first try (V0.1) from DRIZZLE.F V0.97, 9th July 1996
C Modified for new origin of coordinates etc (V0.2), 17th July 1996
C Modified to match up with DRIZZLE V1.05, 14th November 1996
C (rotfir parameter added, few bug fixes, change coordinate origin)
C Match up to Drizzle 1.08 - V0.4 of BLOT, 6th December 1996
C Correct shift units bug, V0.41, 16th December 1996
C Add ALIGN option, V0.42, 16th January 1997
C Use "drutil.f" utilities, no -z, 4th February 1997
C Prepared V0.5 for release, matches V1.097 of Drizzle, 17th March 1997
C
C First public release of Blot, 12th May 1997
C
C Added in_un/out_un switches for compatibility with V1.2 of Drizzle.
C This was for the first release of drizzle/blot in the dither package
C within STSDAS. 25th February 1998.
C
C Added automatic output image size selection, 27th February 1998
C
C Modified calling sequences to match the drutil.f with Drizzle 2.6,
C  December 2001
C
C V1.0 with full geometric support (via the routines in drutil.f)
C  December 2001.
C
C V1.1 with use of new DRIVAL call
C   Richard Hook, ST-ECF, 27th February 2002
C
C V1.3 with cleaner access to coefficients,
C   Richard Hook, ST-ECF, 11th March 2002
C
C V2.0: image subsetting to allow working with very large mosaics,
C       also wblot form for working with WCS. Also additional sinc
C       interpolation kernels.
C        Richard Hook, ST-ECF at STScI, December 2002
C
C V2.01: added test for zero exposure time input.
C        Richard Hook, ST-ECF at STScI, January 2003
C
C V3.0: compatibility with Drizzle 3.0, June 2003.
C
C V3.01: small modification to correctly get output dimensions
C        correctly in all cases,  ST-ECF at STScI, July 2003
C
C V3.1: updated for image distortion arrays.
C         Richard Hook, ST-ECF at STScI, August 2003
C
C V3.2: double precision version.
C         Richard Hook, ST-ECF at STScI, October 2003
C
C V3.32: added support for more kernels, through new interface
C        and scaling for kernel to support experiments.
C            Richard Hook, ST-ECF at STScI, January 2004
C
C V3.3.3 support for Spitzer style header polynomials.
C            Richard Hook, ST-ECF at STScI, March 2004
C
C V3.4:  modified to use common callable code.
C            Warren Hack, STScI, 25th June 2004
C        moved ballme and buhead to ioutil for use with wblot.
C            WJH, STScI, 7 Oct 2005
C
C
C--
      IMPLICIT NONE

C Iraf global storage (real in this program)
      REAL MEMR(1) !I
      DOUBLE PRECISION MEMD(1) !I
      COMMON /MEM/MEMR         !I
      EQUIVALENCE (MEMR,MEMD)  !I

C Local variables
      INTEGER ISTAT,I
      INTEGER NDIMS,DNX,DNY,ONX,ONY,DDIMS(7),ODIMS(7),DATTYP
      INTEGER IDD,IRD,IDND
      INTEGER PDATA,PNDAT,PBUFF
      INTEGER PXIN,PYIN,PXOUT,PYOUT
      INTEGER INTYPE,IC
      INTEGER XMIN,XMAX,YMIN,YMAX
      REAL EF,EXPIN,EXPOUT,EXPREF
      DOUBLE PRECISION LASTPF,LASTSC,LASTOX,LASTOY
      DOUBLE PRECISION WCSIN(8),WCSOUT(8),XREFP,YREFP
      CHARACTER*80 DATA,OUTDAT,REFIMA,CHARS
      CHARACTER*8 CTYPE1,CTYPE2
      CHARACTER*8 EXPKEY,INUN,OUTUN,LASTUN
      CHARACTER*80 EXPSTR
      CHARACTER*45 VERS
      CHARACTER*20 INTERP
      REAL KSCALE,SINSCL
      INTEGER COTY,COMAX,CONUM
      PARAMETER (COMAX=100)
      DOUBLE PRECISION XCO(COMAX),YCO(COMAX)
      REAL MISVAL

      INTEGER MAXPIX
      PARAMETER (MAXPIX=2E7)

C Geometrical parameters, the standard set
      DOUBLE PRECISION SCALE,ROT,XSH,YSH,LAM
      DOUBLE PRECISION XSH2,YSH2,ROT2,XSCALE,YSCALE
      DOUBLE PRECISION RACEN,DECCEN
      DOUBLE PRECISION ORIENT,OUTSCL
      CHARACTER*80 COEFFS,SHFTUN,XGEOIM,YGEOIM
      INTEGER PXG,PYG,XGDIM,YGDIM
      LOGICAL DISIM
      CHARACTER*8 SHFR2,SHFTFR,ALIGN,GEOMOD

C Constants
      DOUBLE PRECISION PI
      PARAMETER (PI=3.1415926536D0)

C Logical flags
      LOGICAL VERBOSE
      LOGICAL GOTWCS
      LOGICAL ROTFIR
      LOGICAL INCPS
      LOGICAL OUTCPS
      LOGICAL USEWCS
      LOGICAL ROTF2
      LOGICAL SECPAR
      LOGICAL SUB
      LOGICAL NOOVER

C-- Start of executable code

C First announce the version
      VERS='WBLOT Version 3.4 (25th June 2004)'

      CALL UMSPUT('+ '//VERS,1,0,ISTAT)

      VERBOSE=.TRUE.

C This line controls whether or not we can have WCS defined geometry
C This line needs to be changed to convert WBLOT to BLOT
CCC      GEOMOD='user'
      GEOMOD=' '

C Get the geomode
      IF(GEOMOD.EQ.' ') CALL UCLGST('geomode',GEOMOD,ISTAT)

C Get all the geometrical parameters
      CALL GTGEPA(GEOMOD,COEFFS,LAM,XGEOIM,YGEOIM,
     :             SCALE,ROT,XSH,YSH,SHFTFR,SHFTUN,ALIGN,
     :             XSCALE,YSCALE,XSH2,YSH2,ROT2,SHFR2,
     :             OUTSCL,RACEN,DECCEN,XREFP,YREFP,ORIENT)

C Get the output dimensions, although these may be overwritten
C by a reference image size if present (3.01 modification)
      CALL UCLGSI('outnx',ONX,ISTAT)
      CALL UCLGSI('outny',ONY,ISTAT)

C Find out whether we are using WCS to define the geometry
      IF(GEOMOD.EQ.'wcs') THEN
         USEWCS=.TRUE.
      ELSE
         USEWCS=.FALSE.
      ENDIF

C Get the exposure related parameters
      CALL UCLGST('expkey',EXPKEY,ISTAT)
      CALL UCLGST('expout',EXPSTR,ISTAT)

C Convert the parameters supplied to the output WCS if needed
C If using WCS...
      IF(USEWCS .OR. COEFFS.EQ.'wcs') THEN

C If we have a reference image we need to try to get its WCS for
C use as the output
         CALL UCLGST('refimage',REFIMA,ISTAT)
         IF(REFIMA.NE.' ') THEN
            CALL UIMOPN(REFIMA,1,IRD,ISTAT)
            IF(ISTAT.NE.0) THEN
               CALL UMSPUT('! Unable to open reference image',
     :                     1,0,ISTAT)
               GO TO 99
            ELSE
               CALL UMSPUT('-Reading WCS from '//REFIMA,1,0,ISTAT)
            ENDIF

            CALL GETWCS(IRD,WCSOUT,CTYPE1,CTYPE2,ISTAT)
            IF(ISTAT.NE.0) THEN
               CALL UMSPUT(
     : '! Unable to get WCS from reference image',
     :                     1,0,ISTAT)
               GO TO 99
            ENDIF

C Get the dimensions and use them
            CALL UIMGID(IRD,DATTYP,NDIMS,DDIMS,ISTAT)
            IF(NDIMS.NE.2) THEN
               CALL UMSPUT(
     :   '! Reference image is not two dimensional',
     :                          1,0,ISTAT)
               GO TO 99
            ELSE
               ONX=DDIMS(1)
               ONY=DDIMS(2)
               WRITE(CHARS,
     :  '(''-Blotted image will be '',I6,'' by '',I6)') ONX,ONY
               CALL UMSPUT(CHARS,1,0,ISTAT)
            ENDIF

C Get the reference image exposure time
            CALL UHDGSR(IRD,EXPKEY,EXPREF,ISTAT)
            IF(ISTAT.NE.0) EXPREF=0.0

C Close the image
            CALL UIMCLO(IRD,ISTAT)
         ELSE

C Now convert these into WCS style representation
            CALL SETWCS(OUTSCL,ORIENT,XREFP,RACEN,
     :               YREFP,DECCEN,WCSOUT)
         ENDIF
      ENDIF

C Get reference frame for shifts - specifying whether shifts are done before
C or after rotation
      IF(SHFTFR.EQ.'output') THEN
         ROTFIR=.FALSE.
      ELSE
         ROTFIR=.TRUE.
      ENDIF

C Convert the secondary parameters into suitable units
      ROT2=ROT2*PI/180.0D0
      IF(SHFR2.EQ.'input') THEN
         ROTF2=.FALSE.
      ELSE
         ROTF2=.TRUE.
      ENDIF

C Give a warning message if secondary parameters will have an effect
      IF(XSCALE.NE.1.0D0 .OR. YSCALE.NE.1.0D0 .OR.
     :   XSH2.NE.0.0D0 .OR. YSH2.NE.0.0D0 .OR. ROT2.NE.0.0D0) THEN
       CALL UMSPUT(
     : '! Warning, secondary geometric transform is being used',
     :               1,0,ISTAT)
        SECPAR=.TRUE.
      ELSE
        SECPAR=.FALSE.
      ENDIF

C Get the switch value for whether to read in CPS or
C counts (latter is the default)
      CALL UCLGST('in_un',INUN,ISTAT)
      IF(INUN.EQ.'cps') THEN
         INCPS=.TRUE.
      ELSE
         INCPS=.FALSE.
      ENDIF

C Get the switch value for whether to write out in CPS or
C counts (latter is the default)
      CALL UCLGST('out_un',OUTUN,ISTAT)
      IF(OUTUN.EQ.'cps') THEN
         OUTCPS=.TRUE.
      ELSE
         OUTCPS=.FALSE.
      ENDIF

C Check for invalid scale
      IF(SCALE.EQ.0.0D0) THEN
         CALL UMSPUT('! Invalid scale',1,0,ISTAT)
         GO TO 99
      ENDIF

C Convert the rot to radians
      ROT=ROT*PI/180.0D0

      IF(SHFTUN.EQ.'input') THEN
         XSH=XSH*SCALE
         YSH=YSH*SCALE
      ENDIF

C Note that the shifts are in INPUT pixel units

C Get the missing value flag
      CALL UCLGSR('fillval',MISVAL,ISTAT)

C Get the name of the input data image
      CALL UCLGST('data',DATA,ISTAT)

C Try to access the input data image
      CALL UIMOPN(DATA,1,IDD,ISTAT)
      IF(ISTAT.NE.0) THEN
         CALL UMSPUT('! Unable to open data image',
     :                    1,0,ISTAT)
         GO TO 99
      ELSE
         IF(VERBOSE) CALL UMSPUT(
     :  '-Opening input data image: '//DATA,
     :                   1,0,ISTAT)
      ENDIF

C Get the array size and shape
      CALL UIMGID(IDD,DATTYP,NDIMS,DDIMS,ISTAT)
      IF(NDIMS.NE.2) THEN
         CALL UMSPUT('! Input image is not two dimensional',
     :                    1,0,ISTAT)
         GO TO 99
      ELSE
         DNX=DDIMS(1)
         DNY=DDIMS(2)
      ENDIF

C We now get some of the previous drizzle information from
C the header of the current image and check for funny
C combinations
      CALL GOLDH(IDD,USEWCS,IC,LASTPF,LASTSC,
     :           LASTUN,LASTOX,LASTOY,ISTAT)

C Check for incompatibilities
      IF(INCPS) THEN
         IF(LASTUN.EQ.'counts' .OR.
     :                LASTUN.EQ.'COUNTS') THEN
          CALL UMSPUT('! Warning input image header gives units',
     :               1,0,ISTAT)
          CALL UMSPUT('! as counts NOT cps! Assuming cps',
     :               1,0,ISTAT)
         ENDIF
      ELSE
         IF(LASTUN.EQ.'cps' .OR.
     :                LASTUN.EQ.'CPS') THEN
          CALL UMSPUT('! Warning input image header gives units',
     :               1,0,ISTAT)
          CALL UMSPUT('! as cps NOT counts! Assuming counts',
     :               1,0,ISTAT)
         ENDIF
      ENDIF

C Get the geometric distortion coefficient information
C If we have a reference image we use that
      IF(COEFFS.EQ.'wcs') THEN
         CALL GETGEO(COEFFS,IRD,LAM,
     :            COTY,COMAX,CONUM,XCO,YCO,ISTAT)
      ELSE
         CALL GETGEO(COEFFS,IDD,LAM,
     :            COTY,COMAX,CONUM,XCO,YCO,ISTAT)
      ENDIF

      IF(ISTAT.NE.0) THEN
         CALL UMSPUT(
     :  '! Error, failed to get geometric distortion coefficients',
     :  1,0,ISTAT)
          GO TO 99
      ENDIF

C  Read in any distortion image corrections, if specified
C  PXG,PYG will default to 2x2 arrays when DISIM returns as FALSE.
C
      CALL GGEOIM(XGEOIM,YGEOIM,PXG,PYG,XGDIM,YGDIM,DISIM)

C We get the name of the output image here
      CALL UCLGST('outdata',OUTDAT,ISTAT)

C Check that a name is specified
      IF(OUTDAT.EQ.' ') THEN
         CALL UMSPUT(
     :       '! No output data array name specified',
     :                   1,0,ISTAT)
           GO TO 99
      ENDIF

C Set the output dimensions, these may be the values from
C the CL or from the reference image
      ODIMS(1)=ONX
      ODIMS(2)=ONY

      IDND=0

C Create the output image
      CALL UIMCRE(OUTDAT,6,2,ODIMS,IDND,ISTAT)

C This call sometimes returns a good status when it should not
C - hence the second test
      IF(ISTAT.NE.0 .OR. IDND.EQ.0) THEN
         CALL UMSPUT(
     :     '! Unable to create output data image',
     :                 1,0,ISTAT)
         GO TO 99
      ELSE
         CALL UMSPUT(
     :     '-Created new output data image: '//OUTDAT,
     :              1,0,ISTAT)
      ENDIF

C Copy the header to the output, this also transfers the exposure
C time information
      CALL UHDCPY(IDD,IDND,ISTAT)

C Also try to get the header items for the WCS, note that
C this is not the full WCS but just 8 header items commonly used
C for HST images plus CTYPE1 & CTYPE2
      CALL GETWCS(IDD,WCSIN,CTYPE1,CTYPE2,ISTAT)
      IF(ISTAT.EQ.0) THEN
         GOTWCS=.TRUE.
      ELSE
         CALL UMSPUT(
     :    '! Warning, unable to read WCS information from header',
     :    1,0,ISTAT)
      ENDIF

C Here we set the WCS matrix to something sensible anyway
      IF(.NOT.GOTWCS) THEN
         CTYPE1='PIXELS'
         CTYPE2='PIXELS'

         DO I=1,8
            WCSIN(I)=0.0D0
         ENDDO

         WCSIN(5)=-1.0D0
         WCSIN(8)=1.0D0
      ENDIF

C Calculate the range of pixels in the input which are accessed
C when blotting
      CALL LCORN(ONX,ONY,DNX,DNY,
     :           XSH,YSH,ROT,SCALE,ALIGN,ROTFIR,
     :           SECPAR,XSH2,YSH2,ROT2,XSCALE,YSCALE,SHFR2,ROTF2,
     :           USEWCS,WCSOUT,WCSIN,
     :           COTY,CONUM,XCO,YCO,
     :           DISIM,MEMR(PXG),MEMR(PYG),XGDIM,YGDIM,
     :           XMIN,XMAX,YMIN,YMAX,ISTAT)

C Assume we are using the whole frame unless set otherwise
      SUB=.FALSE.
      NOOVER=.FALSE.

C Check for no-overlap
      IF(XMAX.LT.1 .OR. YMAX.LT.1 .OR.
     :      XMIN.GT.DNX .OR. YMIN.GT.DNY) THEN
         CALL UMSPUT(
     : '! Warning, there is no overlap of the input image',
     :  1,0,ISTAT)
            WRITE(CHARS,
     : '(''! Input pixel range would be: ['',I7,'':'',I7,
     :      '','',I7,'':'',I7,'']'')') XMIN,XMAX,YMIN,YMAX
         CALL UMSPUT(CHARS,1,0,ISTAT)

         NOOVER=.TRUE.
         XMIN=1
         XMAX=1
         YMIN=1
         YMAX=1
         SUB=.TRUE.
      ELSE
         XMIN=MAX(1,XMIN)
         XMAX=MIN(DNX,XMAX)
         YMIN=MAX(1,YMIN)
         YMAX=MIN(DNY,YMAX)

C Check to see whether we really should use the subset or
C whether it makes more sense to work on the full frame.
C These criteria are a little arbitrary at this stage
         IF(DBLE(YMAX-YMIN+1)/DBLE(DNY).GT.0.5D0 .AND.
     :      DNX*DNY.LT.MAXPIX .OR.
     :      (XMIN.EQ.1 .AND. XMAX.EQ.DNX .AND.
     :      YMIN.EQ.1 .AND. YMAX.EQ.DNY)) THEN

            SUB=.FALSE.
            WRITE(CHARS,'(''-Blotting from full input image.'')')

            XMIN=1
            YMIN=1
            XMAX=DNX
            YMAX=DNY
            SUB=.FALSE.
         ELSE
            WRITE(CHARS,
     : '(''-Blotting from subset: ['',I5,'':'',I5,
     :      '','',I5,'':'',I5,''] ('',F6.2,''%).'')')
     :       XMIN,XMAX,YMIN,YMAX,
     :       100.0*DBLE((XMAX-XMIN+1)*(YMAX-YMIN+1))/
     :       DBLE(DNX*DNY)
            SUB=.TRUE.
         ENDIF

         CALL UMSPUT(CHARS,1,0,ISTAT)
      ENDIF

C Now we have the subarray sorted out we can allocate memory
C arrays and read in the data
      CALL BALLME(DNX,DNY,ONX,ONY,XMAX-XMIN+1,YMAX-YMIN+1,
     :        PBUFF,PDATA,PNDAT,PXIN,PYIN,PXOUT,PYOUT,ISTAT)

C Read in the data array subset
      CALL GETIMR(IDD,DNX,DNY,SUB,XMIN,XMAX,YMIN,YMAX,
     :                  MEMR(PBUFF),MEMR(PDATA),ISTAT)
      IF(ISTAT.NE.0) THEN
         CALL UMSPUT(
     :      '! Failed to read input data image',
     :                   1,0,ISTAT)
         GO TO 99
      ENDIF

C Get the exposure time from the header, if possible
      CALL UHDGSR(IDD,EXPKEY,EXPIN,ISTAT)
      IF(ISTAT.NE.0) THEN
         CALL UMSPUT(
     : '! Warning, failed to get exposure time keyword value',
     :      1,0,ISTAT)
            GO TO 99
      ENDIF

C Check for zero exposure time (yes, it does happen)
      IF(EXPIN.LE.0.0) THEN
         CALL UMSPUT(
     : '! Warning, exposure time <= 0 - setting to 1.0',1,0,ISTAT)
         EXPIN=1.0
      ENDIF

C Check for the "input" value for the output exposure,
C this is the standard behaviour
      IF(EXPSTR.EQ.'INPUT' .OR. EXPSTR.EQ.'input') THEN
         EXPOUT=EXPIN
      ELSE IF(
     :   EXPSTR.EQ.'REFERENCE' .OR. EXPSTR.EQ.'reference') THEN
         IF(EXPREF.EQ.0.0) THEN
            CALL UMSPUT(
     : '! Error - no reference image exposure time found',1,0,ISTAT)
            GO TO 99
         ELSE
            CALL UMSPUT(
     :  '-Using exposure time of reference image for output',
     :                  1,0,ISTAT)
            EXPOUT=EXPREF
         ENDIF
      ELSE
         READ(EXPSTR,*,IOSTAT=ISTAT) EXPOUT
         IF(ISTAT.NE.0) THEN
            CALL UMSPUT('! Invalid output exposure value',
     :                  1,0,ISTAT)
            GO TO 99
         ENDIF
      ENDIF

C Now we re-scale depends on the units, there are four cases
      IF(INCPS) THEN
         IF(OUTCPS) THEN
            EF=1.0
         ELSE
            EF=EXPOUT
         ENDIF
      ELSE
         IF(OUTCPS) THEN
            EF=1.0/EXPIN
         ELSE
            EF=EXPOUT/EXPIN
         ENDIF
      ENDIF

      CALL UHDPSR(IDND,EXPKEY,EXPOUT,ISTAT)
      WRITE(CHARS,
     :    '(''-Input exposure: '',F10.3,'' Output exposure: '''//
     :    'F10.3)') EXPIN,EXPOUT
      CALL UMSPUT(CHARS,1,0,ISTAT)

C Close the data array now we have it
      CALL UIMCLO(IDD,ISTAT)

C The final case is where the output is empty.
C Before we start blotting we need to drain out the output arrays
C if there are no old arrays
      CALL SETIM(MEMR(PNDAT),ONX,ONY,0.0)

C Before we start also get the interpolation type and convert
C to a numerical code
      CALL UCLGST('interpol',INTERP,ISTAT)
      IF(INTERP.EQ.'nearest') THEN
         INTYPE=1
      ELSE IF(INTERP.EQ.'linear') THEN
         INTYPE=2
      ELSE IF(INTERP.EQ.'poly3') THEN
         INTYPE=3
      ELSE IF(INTERP.EQ.'poly5') THEN
         INTYPE=4
      ELSE IF(INTERP.EQ.'spline3') THEN
         INTYPE=5
      ELSE IF(INTERP.EQ.'sinc') THEN
         INTYPE=6
      ELSE IF(INTERP.EQ.'lsinc') THEN
         INTYPE=7
      ELSE IF(INTERP.EQ.'drizzle') THEN
         INTYPE=8
      ELSE IF(INTERP(1:4).EQ.'lan3') THEN
         INTYPE=100
      ELSE IF(INTERP(1:4).EQ.'lan5') THEN
         INTYPE=105
      ELSE
         CALL UMSPUT('! Invalid interpolant specified',
     :               1,0,ISTAT)
         GO TO 99
      ENDIF

C Try to read a kernel scaling factor
      IF(INTYPE.GE.100) THEN
         READ(INTERP(5:),*,IOSTAT=ISTAT) KSCALE
         IF(ISTAT.NE.0) THEN
            KSCALE=1.0
         ELSE
            WRITE(CHARS,'(''-Using kernel scale of: '',F10.4)')
     :            KSCALE
            CALL UMSPUT(CHARS,1,0,ISTAT)
         ENDIF
      ENDIF

C Get the sinc stretch
      CALL UCLGSR('sinscl',SINSCL,ISTAT)

C Now do the actual combination using interpolation
      CALL DOBLOT(MEMR(PDATA),MEMR(PNDAT),INTYPE,SINSCL,KSCALE,MISVAL,
     :      XMIN,XMAX,YMIN,YMAX,DNX,DNY,
     :      ROTFIR,EF,ALIGN,ONX,ONY,COTY,CONUM,XCO,YCO,
     :      DISIM,MEMR(PXG),MEMR(PYG),XGDIM,YGDIM,
     :      MEMD(PXIN),MEMD(PYIN),MEMD(PXOUT),MEMD(PYOUT),
     :      SCALE,ROT,XSH,YSH,USEWCS,WCSIN,WCSOUT,
     :      GEOMOD,SECPAR,XSH2,YSH2,ROT2,XSCALE,YSCALE,SHFR2,ROTF2)

C Write out the new image
      IF(VERBOSE)
     :   CALL UMSPUT('-Writing output blotted image: '//
     :               OUTDAT,1,0,ISTAT)

      CALL UIPS2R(IDND,1,ONX,1,ONY,MEMR(PNDAT),ISTAT)

C Update the header
      CALL BUHEAD(IDND,VERS,DATA,OUTDAT,COEFFS,XGEOIM,YGEOIM,
     :     SHFTUN,MISVAL,
     :     EXPKEY,EXPSTR,ALIGN,INUN,OUTUN,
     :     SHFTFR,INTERP,LAM,SCALE,ROT,XSH,YSH,
     :     SECPAR,XSH2,YSH2,ROT2,XSCALE,YSCALE,SHFR2,ONX,ONY)

      IF(GOTWCS) THEN
         CALL UWCS(IDND,WCSOUT,CTYPE1,CTYPE2)
      ENDIF

      CALL UIMCLO(IDND,ISTAT)
      CALL UDMFRE(PNDAT,6,ISTAT)

C Close down everything and exit
      CALL UDMFRE(PDATA,6,ISTAT)

C If the distortion images have been used free that too
      IF(PXG.NE.0) CALL UDMFRE(PXG,6,ISTAT)
      IF(PYG.NE.0) CALL UDMFRE(PYG,6,ISTAT)

 99   CONTINUE
      END


module hamiltonian_module

  use kinetic_module, only: op_kinetic
  use localpot_module, only: op_localpot, Vloc
  use nonlocal_module, only: op_nonlocal
  use fock_module, only: op_fock
  use watch_module, only: watchb, watchb_omp,time_hmlt

  implicit none

  private
  public :: hamiltonian
  public :: op_kinetic
  public :: op_localpot
  public :: op_nonlocal
!  public :: op_hamiltonian
!  public :: init_op_hamiltonian
!  public :: send_status_to_hamiltonian
!  public :: reset_op_hamiltonian
!  public :: backup_op_hamiltonian
!  public :: prep_work_op_hamiltonian
!  public :: release_work_op_hamiltonian
!  public :: rotv_op_hamiltonian

#ifdef _DRSDFT_
  real(8), public, allocatable :: hpsi_backup(:,:,:,:)
#else
  complex(8), public, allocatable :: hpsi_backup(:,:,:,:)
#endif

  interface op_hamiltonian
    module procedure d_op_hamiltonian, z_op_hamiltonian
  end interface

  interface backup_op_hamiltonian
    module procedure d_backup_op_hamiltonian, z_backup_op_hamiltonian
  end interface

  interface rotv_op_hamiltonian
    module procedure d_rotv_op_hamiltonian, z_rotv_op_hamiltonian
  end interface

  interface hamiltonian
    module procedure d_hamiltonian1, z_hamiltonian1
  end interface

  logical :: USE_BACKUP_AND_RESTORE=.false.
  logical :: BACKUP_AVAILABLE=.false.
  logical :: VLOC_IS_MODIFIED=.false.
  real(8),allocatable :: vloc_backup(:,:)
  real(8),allocatable :: dvloc(:,:)

#ifdef _DRSDFT_
  real(8), allocatable :: hpsi_work(:,:)
#else
  complex(8), allocatable :: hpsi_work(:,:)
#endif

contains

  subroutine hamiltonian0(n,k,s,tpsi,htpsi,n1,n2,ib1,ib2)
    implicit none
    integer,intent(in) :: n,k,s,n1,n2,ib1,ib2
#ifdef _DRSDFT_
    real(8),intent(in)  :: tpsi(n1:,ib1:)
    real(8),intent(out) :: htpsi(n1:,ib1:)
    real(8),parameter :: zero=0.0d0
#else
    complex(8),intent(in)  :: tpsi(n1:,ib1:)
    complex(8),intent(out) :: htpsi(n1:,ib1:)
    complex(8),parameter :: zero=(0.0d0,0.0d0)
#endif
    real(8) :: ttmp(2)

!$omp parallel

!$omp workshare
    htpsi=zero
!$omp end workshare

    !call watchb_omp( ttmp )

! --- Kinetic energy ---

    call op_kinetic( tpsi, htpsi, k, Vloc(:,s) )

!$omp barrier

    !call watchb_omp( ttmp, time_hmlt(1,1) )

! --- local potential ---

    !call op_localpot( tpsi, htpsi, s )

!$omp barrier

    !call watchb_omp( ttmp, time_hmlt(1,2) )

! --- nonlocal potential ---

    call op_nonlocal( tpsi, htpsi, n,k,s )

!$omp barrier

    !call watchb_omp( ttmp, time_hmlt(1,3) )

!$omp end parallel

    !call watchb( ttmp )

    call op_fock( tpsi, htpsi, n,k,s )

    !call watchb( ttmp, time_hmlt(1,4) )

  end subroutine hamiltonian0

  subroutine d_hamiltonian1( tpsi, htpsi, n,k,s )
    implicit none
    integer,intent(in) :: n,k,s
    real(8),intent(in) :: tpsi(:,:)
    real(8),intent(inout) :: htpsi(:,:)
!$omp parallel
    !call watchb_omp( ttmp )
    call op_kinetic( tpsi, htpsi, k, Vloc(:,s) )
!$omp barrier
    !call watchb_omp( ttmp, time_hmlt(1,1) )
    !call op_localpot( tpsi, htpsi, s )
!!$omp barrier
    !call watchb_omp( ttmp, time_hmlt(1,2) )
    call op_nonlocal( tpsi, htpsi, n,k,s )
!$omp barrier
    !call watchb_omp( ttmp, time_hmlt(1,3) )
!$omp end parallel
    !call watchb( ttmp )
    call op_fock( tpsi, htpsi, n,k,s )
    !call watchb( ttmp, time_hmlt(1,4) )
  end subroutine d_hamiltonian1

  subroutine z_hamiltonian1( tpsi, htpsi, n,k,s )
    implicit none
    integer,intent(in) :: n,k,s
    complex(8),intent(in) :: tpsi(:,:)
    complex(8),intent(inout) :: htpsi(:,:)
    !$omp parallel
    !call watchb_omp( ttmp )
    call op_kinetic( tpsi, htpsi, k, Vloc(:,s) )
    !$omp barrier
    !call watchb_omp( ttmp, time_hmlt(1,1) )
    !call op_localpot( tpsi, htpsi, s )
    !!$omp barrier
    !call watchb_omp( ttmp, time_hmlt(1,2) )
    call op_nonlocal( tpsi, htpsi, n,k,s )
    !$omp barrier
    !call watchb_omp( ttmp, time_hmlt(1,3) )
    !$omp end parallel
    !call watchb( ttmp )
    call op_fock( tpsi, htpsi, n,k,s )
    !call watchb( ttmp, time_hmlt(1,4) )
  end subroutine z_hamiltonian1

  subroutine init_op_hamiltonian( lswitch, ng,nb,nk,ns )
    implicit none
    logical, intent(in) :: lswitch
    integer, intent(in) :: ng, nb, nk(2), ns(2)
    call write_border( 0, "init_op_hamiltonian(start)" )
    USE_BACKUP_AND_RESTORE = lswitch
    if( USE_BACKUP_AND_RESTORE )then
       allocate( hpsi_backup(ng,nb,nk(1):nk(2),ns(1):ns(2)) )
       hpsi_backup=(0.0d0,0.0d0)
       allocate( vloc_backup(ng,ns(1):ns(2)) )
       vloc_backup=0.0d0
    end if
    call write_border( 0, "init_op_hamiltonian(end)" )
  end subroutine init_op_hamiltonian

  subroutine d_op_hamiltonian( n,k,s, tpsi, hpsi, backup, restore )
    implicit none
    integer,intent(in)  :: n,k,s
    real(8),intent(in)  :: tpsi(:,:)
    real(8),intent(out) :: hpsi(:,:)
    logical,optional,intent(in) :: backup
    logical,optional,intent(in) :: restore
    real(8) :: ttmp(2)
    integer :: n1,n2,ib,jb
#ifdef _DRSDFT_
    if( USE_BACKUP_AND_RESTORE .and. present(restore) )then
       if( restore .and. BACKUP_AVAILABLE )then
          n1=n
          n2=n+size(hpsi,2)-1
          if( VLOC_IS_MODIFIED )then
             do ib = n1, n2
                jb = ib - n + 1
                !$omp parallel workshare
                hpsi(:,jb)=hpsi_backup(:,ib,k,s)+dvloc(:,s)*tpsi(:,jb)
                !$omp end parallel workshare
             end do
          else
             !$omp parallel workshare
             hpsi(:,:) = hpsi_backup(:,n1:n2,k,s)
             !$omp end parallel workshare
          end if
          return
       end if
    end if

!$omp parallel

!$omp workshare
    !hpsi=0.0d0
!$omp end workshare

    !call watchb_omp( ttmp )

! --- Kinetic energy ---

    call op_kinetic( tpsi, hpsi, k, Vloc(:,s) )

!$omp barrier

    !call watchb_omp( ttmp, time_hmlt(1,1) )

! --- local potential ---

    !call op_localpot( tpsi, hpsi, s )

!$omp barrier

    !call watchb_omp( ttmp, time_hmlt(1,2) )

! --- nonlocal potential ---

    call op_nonlocal( tpsi, hpsi, k, s )

!$omp barrier

    !call watchb_omp( ttmp, time_hmlt(1,3) )

!$omp end parallel

    !call watchb( ttmp )

    call op_fock( tpsi, hpsi, n,k,s )

    !call watchb( ttmp, time_hmlt(1,4) )

    if( USE_BACKUP_AND_RESTORE .and. present(backup) )then
       if ( backup )then
          n1=n
          n2=n+size(hpsi,2)-1
!$omp parallel workshare
          hpsi_backup(:,n1:n2,k,s) = hpsi(:,:)
!$omp end parallel workshare
          BACKUP_AVAILABLE = .true.
          if( VLOC_IS_MODIFIED .eqv. .true. )then
             vloc_backup(:,:) = Vloc(:,:)
             VLOC_IS_MODIFIED = .false.
          end if
       end if
    end if

    !call watchb( ttmp, time_hmlt(1,5) )

#else
    hpsi=0.0d0
#endif

  end subroutine d_op_hamiltonian

  subroutine z_op_hamiltonian( n,k,s, tpsi, hpsi, backup, restore )
    implicit none
    integer,intent(in) :: n,k,s
    complex(8),intent(in)  :: tpsi(:,:)
    complex(8),intent(out) :: hpsi(:,:)
    logical,optional,intent(in) :: backup
    logical,optional,intent(in) :: restore
    real(8) :: ttmp(2)
    integer :: n1,n2,ib,jb
#ifndef _DRSDFT_
    if( USE_BACKUP_AND_RESTORE .and. present(restore) )then
       if ( restore .and. BACKUP_AVAILABLE )then
          n1=n
          n2=n+size(hpsi,2)-1
          if( VLOC_IS_MODIFIED )then
             do ib = n1, n2
                jb = ib - n + 1
                !$omp parallel workshare
                hpsi(:,jb)=hpsi_backup(:,ib,k,s)+dvloc(:,s)*tpsi(:,jb)
                !$omp end parallel workshare
             end do
          else
             !$omp parallel workshare
             hpsi(:,:) = hpsi_backup(:,n1:n2,k,s)
             !$omp end parallel workshare
          end if
          return
       end if
    end if

!$omp parallel

!$omp workshare
    !hpsi=(0.0d0,0.0d0)
!$omp end workshare

    !call watchb_omp( ttmp )

! --- Kinetic energy ---

    call op_kinetic( tpsi, hpsi, k, Vloc(:,s) )

!$omp barrier

    !call watchb_omp( ttmp, time_hmlt(1,1) )

! --- local potential ---

    !call op_localpot( tpsi, hpsi, s )

!$omp barrier

    !call watchb_omp( ttmp, time_hmlt(1,2) )

! --- nonlocal potential ---

    call op_nonlocal( tpsi, hpsi, k, s )

!$omp barrier

    !call watchb_omp( ttmp, time_hmlt(1,3) )

!$omp end parallel

    !call watchb( ttmp )

    call op_fock( tpsi, hpsi, n,k,s )

    !call watchb( ttmp, time_hmlt(1,4) )

    if( USE_BACKUP_AND_RESTORE .and. present(backup) )then
       if( backup )then
          n1=n
          n2=n+size(hpsi,2)-1
          !$omp parallel workshare
          hpsi_backup(:,n1:n2,k,s) = hpsi(:,:)
          !$omp end parallel workshare
          BACKUP_AVAILABLE = .true.
          if( VLOC_IS_MODIFIED .eqv. .true. )then
             vloc_backup(:,:) = Vloc(:,:)
             VLOC_IS_MODIFIED = .false.
          end if
       end if
    end if

    !call watchb( ttmp, time_hmlt(1,5) )

#else
    hpsi=(0.0d0,0.0d0)
#endif
  end subroutine z_op_hamiltonian

  subroutine send_status_to_hamiltonian( msg )
    implicit none
    character(*),intent(in) :: msg
    integer :: a,b,c
    if ( .not.USE_BACKUP_AND_RESTORE ) return
    select case( msg )
    case( "vloc is modified" )
       if( .not.allocated(dvloc) )then
          a=size(Vloc,1)
          b=lbound(Vloc,2)
          c=ubound(Vloc,2)
          allocate( dvloc(a,b:c) ); dvloc=0.0d0
       end if
       VLOC_IS_MODIFIED=.true.
       dvloc = Vloc - vloc_backup
       vloc_backup = Vloc
    case( "wf is modified" )
       BACKUP_AVAILABLE=.false.
    case default
       write(*,*) "msg= ",msg
       call stop_program("stop@send_status_to_hamiltonian")
    end select
  end subroutine send_status_to_hamiltonian

  subroutine reset_op_hamiltonian
    implicit none
    BACKUP_AVAILABLE=.false.
    VLOC_IS_MODIFIED=.false.
    if ( allocated(hpsi_backup) ) hpsi_backup=(0.0d0,0.0d0)
    if ( allocated(vloc_backup) ) vloc_backup=0.0d0
    if ( allocated(dvloc) ) dvloc=0.0d0
  end subroutine reset_op_hamiltonian

  subroutine d_backup_op_hamiltonian( n,k,s,hpsi )
    implicit none
    integer, intent(in) :: n, k, s
    real(8), intent(in) :: hpsi(:)
    if ( .not.USE_BACKUP_AND_RESTORE ) return
    !$omp parallel workshare
    hpsi_backup(:,n,k,s) = hpsi(:)
    !$omp end parallel workshare
    BACKUP_AVAILABLE = .true.
  end subroutine d_backup_op_hamiltonian

  subroutine z_backup_op_hamiltonian( n,k,s,hpsi )
    implicit none
    integer, intent(in) :: n, k, s
    complex(8), intent(in) :: hpsi(:)
    if ( .not.USE_BACKUP_AND_RESTORE ) return
    !$omp parallel workshare
    hpsi_backup(:,n,k,s) = hpsi(:)
    !$omp end parallel workshare
    BACKUP_AVAILABLE = .true.
  end subroutine z_backup_op_hamiltonian

  subroutine prep_work_op_hamiltonian( ml0, mb0, mb1 )
    implicit none
    integer,intent(in) :: ml0, mb0, mb1
    if ( .not.(USE_BACKUP_AND_RESTORE.and.BACKUP_AVAILABLE) ) return
    allocate( hpsi_work(ml0,mb0:mb1) ); hpsi_work=(0.0d0,0.0d0)
  end subroutine prep_work_op_hamiltonian

  subroutine release_work_op_hamiltonian( k, s )
    implicit none
    integer,intent(in) :: k, s
    integer :: mb0,mb1
    if ( .not.USE_BACKUP_AND_RESTORE ) return
    if ( allocated(hpsi_work) ) then
       mb0=lbound(hpsi_work,2)
       mb1=ubound(hpsi_work,2)
       hpsi_backup(:,mb0:mb1,k,s)=hpsi_work
       BACKUP_AVAILABLE=.true.
       deallocate(hpsi_work)
    end if
  end subroutine release_work_op_hamiltonian

  subroutine d_rotv_op_hamiltonian( k,s,i1,ii,ms,ns,RotMat )
    implicit none
    integer,intent(in) :: k,s,i1,ii,ms,ns
    real(8),intent(in) :: RotMat(:,:)
    real(8),parameter :: one=1.0d0
    integer :: mm,nn,ll
    if ( .not.(USE_BACKUP_AND_RESTORE.and.BACKUP_AVAILABLE) ) return
    call write_border( 0, "d_rotv_op_hamiltonian" )
    mm=size(RotMat,1)
    nn=size(RotMat,2)
    ll=size(hpsi_backup,1)
    call dgemm('N','N',ii,nn,mm,one,hpsi_backup(i1,ms,k,s),ll &
               ,RotMat,mm,one,hpsi_work(i1,ns),ll)
  end subroutine d_rotv_op_hamiltonian

  subroutine z_rotv_op_hamiltonian( k,s,i1,ii,ms,ns,RotMat )
    implicit none
    integer,intent(in) :: k,s,i1,ii,ms,ns
    complex(8),intent(in) :: RotMat(:,:)
    complex(8),parameter :: one=(1.0d0,0.0d0)
    integer :: mm,nn,ll
    if ( .not.(USE_BACKUP_AND_RESTORE.and.BACKUP_AVAILABLE) ) return
    mm=size(RotMat,1)
    nn=size(RotMat,2)
    ll=size(hpsi_backup,1)
    call zgemm('N','N',ii,nn,mm,one,hpsi_backup(i1,ms,k,s),ll &
               ,RotMat,mm,one,hpsi_work(i1,ns),ll)
  end subroutine z_rotv_op_hamiltonian

end module hamiltonian_module


!*******************************************************************************
!  File ipch_mc.f
!  Contains module ipch_mc
!           SUBROUTINE ipch_mc_model_compute
!           FUNCTION emissivity_model
!
!  Module is part of the V3FIT stellarator equilibrium reconstruction code.
!  The postfix _mc in the name indicates Model Compute
!  The module contains the subroutine ipch_mc_model_compute
!  Both an ipch_desc and a model are needed for this computation.

!*******************************************************************************
!  MODULE ipch_mc
!    (ipch - Interferometry-Polarimetry Model Compute Calculations)
! SECTION I.     VARIABLE DECLARATIONS
! SECTION II.    INTERFACE BLOCKS
! SECTION III.   MAIN COMPUTATIONAL SUBROUTINE
! SECTION IV.    _OLD (SUPERCEDED) CODE
! SECTION X.  COMMENTS FOR DIFFERENT REVISIONS
!*******************************************************************************
      MODULE ipch_mc

!*******************************************************************************
! SECTION I. VARIABLE DECLARATIONS
!*******************************************************************************

!-------------------------------------------------------------------------------
!  Type declarations, constants, utilities
!-------------------------------------------------------------------------------
      USE stel_kinds
      USE v3f_global
      USE vmec_utils
      USE read_wout_mod

!-------------------------------------------------------------------------------
!  ipch Derived Type
!-------------------------------------------------------------------------------
      USE ipch_T

!-------------------------------------------------------------------------------
!  Model Derived Types
!-------------------------------------------------------------------------------
      USE model_T

!------------------------------------------------------------------------------
      IMPLICIT NONE

!*******************************************************************************
! SECTION II.  INTERFACE BLOCKS
!*******************************************************************************

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      CONTAINS

!*******************************************************************************
! SECTION III.  MAIN COMPUTATIONAL SUBROUTINE
!*******************************************************************************
!-------------------------------------------------------------------------------
!  Compute an ipch signal
!
!    Information comes from the ipch_desc and the model
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!  Actual computation of the model signal is in this subroutine
!    s_type = diagnostic
!      d_type = ipch
!        Interferometry-Polarimetry Diagnostic
!        signal_model_compute_ipch
!
!-------------------------------------------------------------------------------

      SUBROUTINE ipch_mc_model_compute(a_ipch,a_model,mod_signal,              &
     &   mod_sigma)

!-------------------------------------------------------------------------------
! ARGUMENTS
! a_ipch        - type ipch_desc - holds ip chord info
! a_model       - type model - holds eq_state and density model information
! mod_signal    - output of the generated signal
! mod_sigma     - output sigma
!-------------------------------------------------------------------------------
      TYPE (ipch_desc), INTENT (inout)     :: a_ipch
      TYPE (model), INTENT (inout), TARGET :: a_model
      REAL(rprec), POINTER, DIMENSION(:) :: mod_signal, mod_sigma

!-------------------------------------------------------------------------------
! local variables
!-------------------------------------------------------------------------------
      CHARACTER(len=*), PARAMETER :: sub_name =                                &
     &  'ipch_mc_model_compute'

!-------------------------------------------------------------------------------
! cyl2flx declarations  - used for the subroutine cyl2flx call
!-------------------------------------------------------------------------------
      REAL(rprec), DIMENSION(3) :: r_cyl(1:3)=0.0
      REAL(rprec), DIMENSION(3) :: xcart, dxcart
      INTEGER :: points

!-------------------------------------------------------------------------------
! other declarations
!
!-------------------------------------------------------------------------------
      INTEGER       :: istat1
      REAL(rprec)   :: dx               ! integration step size
      INTEGER       :: ipoints          ! number of integration points
      INTEGER       :: istep
      REAL(rprec), DIMENSION(:), ALLOCATABLE :: ipem_array

!-------------------------------------------------------------------------------
!  START OF EXECUTABLE CODE
!-------------------------------------------------------------------------------
!  Allocate data and sigma
         IF (ASSOCIATED(mod_signal)) THEN
           DEALLOCATE(mod_signal,mod_sigma, stat=istat1)
           CALL assert_eq(0,istat1,sub_name //                                 &
     &                     'mod_signal, sigma dealloc')
         ENDIF
         ALLOCATE(mod_signal(1),mod_sigma(1),stat=istat1)
         CALL assert_eq(0,istat1,sub_name // 'mod_signal, sigma alloc')

!  Allocate space for ipem_array
         ipoints=200
         ALLOCATE(ipem_array(ipoints),stat=istat1)
         CALL assert_eq(0,istat1,sub_name // 'alloc ipem_array')

         dxcart = (a_ipch % xcart_f - a_ipch % xcart_i)/ipoints
         dx = SQRT(dxcart(1) ** 2 + dxcart(2) ** 2 + dxcart(3) ** 2)
         DO istep=1,ipoints
            xcart = a_ipch % xcart_i + istep * dxcart
            r_cyl(1) = SQRT(xcart(1) ** 2 + xcart(2) ** 2)
            r_cyl(2) = ATAN2(xcart(2),xcart(1))
            r_cyl(3) = xcart(3)
            SELECT CASE(a_ipch % ip_type)

            CASE DEFAULT
               ipem_array(istep) =                                             &
     &            model_get_ip_i_xcyl(a_model,r_cyl) * dx
            END SELECT
         ENDDO
         mod_signal(1)=SUM(ipem_array)
         DEALLOCATE(ipem_array,stat=istat1)
         CALL assert_eq(0,istat1,sub_name // 'dealloc ipem_array')

! make up a sigma
!         mod_sigma(1)=0.5   Changed to zero JDH 2011-10-17
         mod_sigma(1)=0.0

      END SUBROUTINE ipch_mc_model_compute

!*******************************************************************************
! SECTION X.  COMMENTS FOR DIFFERENT REVISIONS
!*******************************************************************************
!
!  JDH 2009-03-03. First version of module. Based on coding from previous
!    module signal_model
!
!  GJH 2010-01-20. SXR version of coding based on module mddc_mc
!
!  JDH 2011-07-28
!    Refactoring - move emissivity function to the model. Test.
!    Moved to _old - sxrch_mc_model_compute_old and emissivity_model_old
!
!  JDH 2011-08-01
!    Refactor sxrc -> sxrch
!
!  JDH 2011-09-08
!    Remove old code. Use eq_get_flux instead of cyl2flx.
!
!  JDH 2011-10-17
!     Change to cartesian coordinates in sxrch
!
!  JDH 2011-10-25
!     Some refactoring, changed s_array to sxrem_array.
!
!  JDH 2012-03-15
!    First version for ip - based on sxr

      END MODULE ipch_mc


*
*     ------------------------------------------------------------------
*	G S T A T E
*     ------------------------------------------------------------------
*
      SUBROUTINE GSTATE(NFIRST,NLAST)
      PARAMETER (NWD=30,NCD=2000,NWD2=2*NWD,NCD4=4*NCD)
*
      COMMON/INFORM/ IREADI,IWRITE,IOUT,IREADF,ISC(7)
      COMMON/STATES/NCFG,MAXORB,IAJCMP(NWD2),LJCOMP(NWD2),NJCOMP(NWD2),
     :NOCCSH(NCD4),NELCSH(5,NCD4),NOCORB(5,NCD4),J1QNRD(9,NCD4)
      COMMON/NOR/NCOM,NORBI,NORBF,IWAR
      CHARACTER*1 JCQN(9)
      DIMENSION J1QN(9),J2QN(9),J3QN(9)
      CHARACTER*8 LABEL(2)
      DATA LABEL/'INITIAL','FINAL'/
*
*      DATA DEFINING THE STATE IS READ IN AND PRINTED OUT.
*
    5 FORMAT(5(1X,A3,1H(,I2,1H)))
    6 FORMAT(9(1X,4X,I1,A1,I1))
   24 FORMAT(//31H INITIAL STATE CONFIGURATIONS:-)
   25 FORMAT(/5H     ,I3,3H.  ,10(1X,A3,1H(,I2,1H)))
   26 FORMAT(11X,10(1X,4X,I1,A1,I1))
   27 FORMAT(22X,9(1X,4X,I1,A1,I1))
   28 FORMAT(  31H ----------------------------  /)
   29 FORMAT(//29H FINAL STATE CONFIGURATIONS:-)
   30 FORMAT(2X,'ELECTRON ',A3,' NOT FOUND IN THE LIST OF ELECTRONS',
     :   ' FOR THE ',A8,' STATE')
      IF (NFIRST .EQ. 1) THEN
         WRITE(IWRITE,24)
         IREAD =IREADI
        ELSE
         WRITE(IWRITE,29)
         IREAD = IREADF
      END IF
      WRITE(IWRITE,28)
      DO 2 I=NFIRST,NLAST
      N=NOCCSH(I)
      READ(IREAD,5)        (NOCORB(J,I),NELCSH(J,I),J=1,N)
      K=I
      IF(NFIRST.NE.1) K=I-NFIRST+1
      WRITE(IWRITE,25) K,(NOCORB(J,I),NELCSH(J,I),J=1,N)
      NCOM1 = NCOM + 1
      NOR11 = NCOM1 + NORBI
      DO 61 J=1,N
      DO 63 JJ = 1,MAXORB
      IF (NFIRST .EQ. 1 .AND. JJ .GE. NOR11) GO TO 65
      IF(NFIRST .NE. 1 .AND. JJ .GE. NCOM1 .AND. JJ .LT. NOR11) GO TO 63
      IF(NOCORB(J,I).EQ.IAJCMP(JJ)) THEN
         NOCORB(J,I) = JJ
         GO TO 61
      END IF
   63    CONTINUE
*
*        ELECTRON NOT FOUND IN THE LIST
*
   65 WRITE(IWRITE,30) NOCORB(J,I),LABEL(NFIRST)
      STOP
   61 CONTINUE
      M=2*N-1
      N1=N+1
      READ(IREAD,6)    (J3QN(J),JCQN(J),J1QN(J),J=1,M)
      WRITE(IWRITE,26) (J3QN(J),JCQN(J),J1QN(J),J=1,N)
      IF(N.EQ.1) GO TO 64
      WRITE(IWRITE,27) (J3QN(J),JCQN(J),J1QN(J),J=N1,M)
   64 CONTINUE
      DO 62 J=1,M
      J2QN(J) = 2*LVAL(JCQN(J)) + 1
   62 J1QNRD(J,I)= (J3QN(J)*64 + J2QN(J))*64 + J1QN(J)
    2 CONTINUE
      RETURN
      END


module stptmod

!$$$ module documentation block
!           .      .    .                                       .
! module:   stptmod    module for stpt and its tangent linear stpt_tl
!  prgmmr:
!
! abstract: module for stpt and its tangent linear stpt_tl
!
! program history log:
!   2005-05-19  Yanqiu zhu - wrap stpt and its tangent linear stpt_tl into one module
!   2005-11-16  Derber - remove interfaces
!   2008-12-02  Todling - remove stpt_tl
!   2009-08-12  lueken - update documentation
!   2013-10-28  todling - rename p3d to prse
!   2014-04-12       su - add non linear qc from Purser's scheme
!   2015-02-26       su - add njqc as an option to choos new non linear qc
!   2016-05-18  guo     - replaced ob_type with polymorphic obsNode through type casting
!
! subroutines included:
!   sub stpt
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
implicit none

PRIVATE
PUBLIC stpt

contains

subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    stpt        calculate penalty and contribution to stepsize
!                            from temperatures, using non-linear qc
!   prgmmr: derber           org: np23                date: 1991-02-26
!
! abstract: calculate penalty and contribution to stepsize from temperatures,
!              using nonlinear qc.
!
! program history log:
!   1991-02-26  derber
!   1998-02-03  weiyu yang
!   1999-08-24  derber, j., treadon, r., yang, w., first frozen mpp version
!   2004-08-02  treadon - add only to module use, add intent in/out
!   2004-10-05  parrish - add non-linear qc option
!   2005-04-11  treadon - merge stpt and stpt_qc into single routine
!   2005-08-02  derber  - modify for variational qc parameters for each ob
!   2005-09-28  derber  - consolidate location and weight arrays
!   2005-10-21  su      - modify for variational qc
!   2005-12-20  parrish - add code to enable boundary layer forward model option
!   2007-03-19  tremolet - binning of observations
!   2007-07-28  derber  - modify to use new inner loop obs data structure
!                       - unify NL qc
!   2006-07-28  derber  - modify output for b1 and b3 and add sensible temperature
!   2007-06-04  derber  - use quad precision to get reproducability over number of processors
!   2008-06-02  safford - rm unused var and uses
!   2008-12-03  todling - changed handling of ptr%time
!   2010-01-04  zhang,b - bug fix: accumulate penalty for multiple obs bins
!   2010-03-25  zhu     - use state_vector in the interface;
!                       - add handling of sst case; add pointer_state
!   2010-05-13  todling - update to use gsi_bundle
!                       - on-the-spot handling of non-essential vars
!   2013-05-23  zhu     - add search direction for aircraft data bias predictors
!   2013-10-29  todling - tendencies now in bundle
!   2015-12-21  yang    - Parrish's correction to the previous code in new varqc.
!
!   input argument list:
!     thead
!     rt       - search direction for sensible t
!     st       - analysis increment for sensible t
!     rtv      - search direction for virtual t
!     stv      - analysis increment for virtual t
!     rq       - search direction for q
!     sq       - analysis increment for q
!     ru       - search direction for u
!     su       - analysis increment for u
!     rv       - search direction for v
!     sv       - analysis increment for v
!     rp       - search direction for p
!     sp       - analysis increment for p
!     rsst     - search direction for sst
!     ssst     - analysis increment for sst
!     sges     - step size estimates (nstep)
!     nstep    - number of stepsizes (==0 means use outer iteration values)
!     rpred    - search direction for predictors
!     spred    - input predictor values
!
!   output argument list:
!     out(1:nstep)   - penalty from temperature observations sges(1:nstep)
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds, only: r_kind,i_kind,r_quad
  use qcmod, only: nlnqc_iter,varqc_iter,njqc,vqc
  use constants, only: zero,half,one,two,tiny_r_kind,cg_term,zero_quad,r3600
  use aircraftinfo, only: npredt,ntail,aircraft_t_bc_pof,aircraft_t_bc
  use gsi_bundlemod, only: gsi_bundle
  use gsi_bundlemod, only: gsi_bundlegetpointer
  use m_obsNode, only: obsNode
  use m_tNode  , only: tNode
  use m_tNode  , only: tNode_typecast
  use m_tNode  , only: tNode_nextcast
  implicit none

! Declare passed variables
  class(obsNode), pointer             ,intent(in   ) :: thead
  integer(i_kind)                     ,intent(in   ) :: nstep
  real(r_quad),dimension(max(1,nstep)),intent(inout) :: out
  real(r_kind),dimension(max(1,nstep)),intent(in   ) :: sges
  real(r_kind),dimension(npredt,ntail),optional,intent(in   ) :: rpred,spred
  type(gsi_bundle),intent(in) :: dval
  type(gsi_bundle),intent(in) :: xval

! Declare local variables
  integer(i_kind) ier,istatus,isst
  integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,kk,n,ix
  real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8
  real(r_kind) cg_t,val,val2,wgross,wnotgross,t_pg
  real(r_kind),dimension(max(1,nstep))::pen,tt
  real(r_kind) tg_prime,valq,valq2,valp,valp2,valu,valu2
  real(r_kind) ts_prime,valv,valv2,valsst,valsst2
  real(r_kind) qs_prime
  real(r_kind) us_prime
  real(r_kind) vs_prime
  real(r_kind) psfc_prime
  type(tNode), pointer :: tptr
  real(r_kind),pointer,dimension(:) :: rt,st,rtv,stv,rq,sq,ru,su,rv,sv
  real(r_kind),pointer,dimension(:) :: rsst,ssst
  real(r_kind),pointer,dimension(:) :: rp,sp

  out=zero_quad

!  If no t data return
  if(.not. associated(thead))return

! Retrieve pointers
  ier=0; isst=0
  call gsi_bundlegetpointer(xval,'u',   su, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(xval,'v',   sv, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(xval,'tsen',st, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(xval,'tv',  stv,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(xval,'q',   sq, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(xval,'prse',sp, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(xval,'sst',ssst,istatus);isst=istatus+isst
  if(ier/=0)return

  call gsi_bundlegetpointer(dval,'u',   ru, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(dval,'v',   rv, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(dval,'tsen',rt, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(dval,'tv',  rtv,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(dval,'q',   rq, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(dval,'prse',rp, istatus);ier=istatus+ier
  call gsi_bundlegetpointer(dval,'sst',rsst,istatus);isst=istatus+isst
  if(ier/=0)return

  tptr => tNode_typecast(thead)
  do while (associated(tptr))

     if(tptr%luse)then
        if(nstep > 0)then
           j1=tptr%ij(1)
           j2=tptr%ij(2)
           j3=tptr%ij(3)
           j4=tptr%ij(4)
           j5=tptr%ij(5)
           j6=tptr%ij(6)
           j7=tptr%ij(7)
           j8=tptr%ij(8)
           w1=tptr%wij(1)
           w2=tptr%wij(2)
           w3=tptr%wij(3)
           w4=tptr%wij(4)
           w5=tptr%wij(5)
           w6=tptr%wij(6)
           w7=tptr%wij(7)
           w8=tptr%wij(8)
!    Note time derivative stuff not consistent for virtual temperature

           if(tptr%tv_ob)then
              val= w1*rtv(j1)+w2*rtv(j2)+w3*rtv(j3)+w4*rtv(j4)+ &
                   w5*rtv(j5)+w6*rtv(j6)+w7*rtv(j7)+w8*rtv(j8)

              val2=w1*stv(j1)+w2*stv(j2)+w3*stv(j3)+w4*stv(j4)+ &
                   w5*stv(j5)+w6*stv(j6)+w7*stv(j7)+w8*stv(j8)
           else
              val= w1*    rt(j1)+w2*    rt(j2)+w3*    rt(j3)+w4*    rt(j4)+ &
                   w5*    rt(j5)+w6*    rt(j6)+w7*    rt(j7)+w8*    rt(j8)
              val2=w1*    st(j1)+w2*    st(j2)+w3*    st(j3)+w4*    st(j4)+ &
                   w5*    st(j5)+w6*    st(j6)+w7*    st(j7)+w8*    st(j8)
           end if

!          contribution from bias correction
           if ((aircraft_t_bc_pof .or. aircraft_t_bc) .and. tptr%idx>0) then
              ix=tptr%idx
              do n=1,npredt
                 val2=val2+spred(n,ix)*tptr%pred(n)
                 val =val +rpred(n,ix)*tptr%pred(n)
              end do
           end if

           do kk=1,nstep
              tt(kk)=val2+sges(kk)*val
           end do

           if(tptr%use_sfc_model) then

              if (isst==0) then
                 valsst =w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4)
                 valsst2=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4)
              else
                 valsst =zero
                 valsst2=zero
              end if
              valq =w1* rq(j1)+w2* rq(j2)+w3* rq(j3)+w4* rq(j4)
              valq2=w1* sq(j1)+w2* sq(j2)+w3* sq(j3)+w4* sq(j4)
              valu =w1* ru(j1)+w2* ru(j2)+w3* ru(j3)+w4* ru(j4)
              valu2=w1* su(j1)+w2* su(j2)+w3* su(j3)+w4* su(j4)
              valv =w1* rv(j1)+w2* rv(j2)+w3* rv(j3)+w4* rv(j4)
              valv2=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4)
              valp =w1* rp(j1)+w2* rp(j2)+w3* rp(j3)+w4* rp(j4)
              valp2=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4)
              do kk=1,nstep
                 ts_prime=tt(kk)
                 tg_prime=valsst2+sges(kk)*valsst
                 qs_prime=valq2+sges(kk)*valq
                 us_prime=valu2+sges(kk)*val
                 vs_prime=valv2+sges(kk)*val
                 psfc_prime=val2+sges(1)*val

                 tt(kk)=psfc_prime*tptr%tlm_tsfc(1) + tg_prime*tptr%tlm_tsfc(2) + &
                        ts_prime  *tptr%tlm_tsfc(3) + qs_prime*tptr%tlm_tsfc(4) + &
                        us_prime  *tptr%tlm_tsfc(5) + vs_prime*tptr%tlm_tsfc(6)
              end do

           end if

           do kk=1,nstep
              tt(kk)=tt(kk)-tptr%res
           end do
        else
           tt(1)=tptr%res
        end if

        do kk=1,max(1,nstep)
           pen(kk) = tt(kk)*tt(kk)*tptr%err2
        end do

!  Modify penalty term if nonlinear QC

        if (vqc .and. nlnqc_iter .and. tptr%pg > tiny_r_kind .and. tptr%b >tiny_r_kind) then
           t_pg=tptr%pg*varqc_iter
           cg_t=cg_term/tptr%b
           wnotgross= one-t_pg
           wgross =t_pg*cg_t/wnotgross
           do kk=1,max(1,nstep)
              pen(kk) = -two*log((exp(-half*pen(kk))+wgross)/(one+wgross))
           end do
        endif

!       Note:  if wgross=0 (no gross error, then wnotgross=1 and this all
!              reduces to the linear case (no qc)

!  Jim Purse's non linear QC scheme
        if(njqc .and. tptr%jb  > tiny_r_kind .and. tptr%jb <10.0_r_kind) then
           do kk=1,max(1,nstep)
              pen(kk) = two*two*tptr%jb*log(cosh(sqrt(pen(kk)/(two*tptr%jb))))
           enddo
           out(1) = out(1)+pen(1)*tptr%raterr2
           do kk=2,nstep
              out(kk) = out(kk)+(pen(kk)-pen(1))*tptr%raterr2
           end do
        else
           out(1) = out(1)+pen(1)*tptr%raterr2
           do kk=2,nstep
              out(kk) = out(kk)+(pen(kk)-pen(1))*tptr%raterr2
           end do
        endif

     endif
     tptr => tNode_nextcast(tptr)

  end do
  return
end subroutine stpt

end module stptmod