! SUMMA - Structure for Unifying Multiple Modeling Alternatives
! Copyright (C) 2014-2015 NCAR/RAL
!
! This file is part of SUMMA
!
! For more information see: http://www.ral.ucar.edu/projects/summa
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

module eval8summa_module

! data types
USE nrtype

! access missing values
USE globalData,only:integerMissing  ! missing integer
USE globalData,only:realMissing     ! missing double precision number
USE globalData,only:quadMissing     ! missing quadruple precision number

! access the global print flag
USE globalData,only:globalPrintFlag

! define access to state variables to print
USE globalData,only: iJac1          ! first layer of the Jacobian to print
USE globalData,only: iJac2          ! last layer of the Jacobian to print

! domain types
USE globalData,only:iname_veg       ! named variables for vegetation
USE globalData,only:iname_snow      ! named variables for snow
USE globalData,only:iname_soil      ! named variables for soil

! named variables to describe the state variable type
USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space
USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy
USE globalData,only:iname_watCanopy ! named variable defining the mass of water on the vegetation canopy
USE globalData,only:iname_nrgLayer  ! named variable defining the energy state variable for snow+soil layers
USE globalData,only:iname_watLayer  ! named variable defining the total water state variable for snow+soil layers
USE globalData,only:iname_liqLayer  ! named variable defining the liquid  water state variable for snow+soil layers
USE globalData,only:iname_matLayer  ! named variable defining the matric head state variable for soil layers
USE globalData,only:iname_lmpLayer  ! named variable defining the liquid matric potential state variable for soil layers

! constants
USE multiconst,only:&
                    Tfreeze,      & ! temperature at freezing              (K)
                    LH_fus,       & ! latent heat of fusion                (J kg-1)
                    LH_vap,       & ! latent heat of vaporization          (J kg-1)
                    LH_sub,       & ! latent heat of sublimation           (J kg-1)
                    Cp_air,       & ! specific heat of air                 (J kg-1 K-1)
                    iden_air,     & ! intrinsic density of air             (kg m-3)
                    iden_ice,     & ! intrinsic density of ice             (kg m-3)
                    iden_water      ! intrinsic density of liquid water    (kg m-3)

! provide access to the derived types to define the data structures
USE data_types,only:&
                    var_i,        & ! data vector (i4b)
                    var_d,        & ! data vector (dp)
                    var_ilength,  & ! data vector with variable length dimension (i4b)
                    var_dlength,  & ! data vector with variable length dimension (dp)
                    model_options   ! defines the model decisions

! look-up values for the choice of groundwater representation (local-column, or single-basin)
USE mDecisions_module,only:  &
 localColumn,                & ! separate groundwater representation in each local soil column
 singleBasin                   ! single groundwater store over the entire basin

! look-up values for the choice of groundwater parameterization
USE mDecisions_module,only:  &
 qbaseTopmodel,              & ! TOPMODEL-ish baseflow parameterization
 bigBucket,                  & ! a big bucket (lumped aquifer model)
 noExplicit                    ! no explicit groundwater parameterization

! look-up values for the form of Richards' equation
USE mDecisions_module,only:  &
 moisture,                   & ! moisture-based form of Richards' equation
 mixdform                      ! mixed form of Richards' equation

implicit none
private
public::eval8summa

contains

 ! **********************************************************************************************************
 ! public subroutine eval8summa: compute the residual vector and the Jacobian matrix
 ! **********************************************************************************************************
 subroutine eval8summa(&
                       ! input: model control
                       dt,                      & ! intent(in):    length of the time step (seconds)
                       nSnow,                   & ! intent(in):    number of snow layers
                       nSoil,                   & ! intent(in):    number of soil layers
                       nLayers,                 & ! intent(in):    total number of layers
                       nState,                  & ! intent(in):    total number of state variables
                       firstSubStep,            & ! intent(in):    flag to indicate if we are processing the first sub-step
                       firstFluxCall,           & ! intent(inout): flag to indicate if we are processing the first flux call
                       firstSplitOper,          & ! intent(in):    flag to indicate if we are processing the first flux call in a splitting operation
                       computeVegFlux,          & ! intent(in):    flag to indicate if we need to compute fluxes over vegetation
                       ! input: state vectors
                       stateVecTrial,           & ! intent(in):    model state vector
                       fScale,                  & ! intent(in):    function scaling vector
                       sMul,                    & ! intent(in):    state vector multiplier (used in the residual calculations)
                       ! input: data structures
                       model_decisions,         & ! intent(in):    model decisions
                       type_data,               & ! intent(in):    type of vegetation and soil
                       attr_data,               & ! intent(in):    spatial attributes
                       mpar_data,               & ! intent(in):    model parameters
                       forc_data,               & ! intent(in):    model forcing data
                       bvar_data,               & ! intent(in):    average model variables for the entire basin
                       prog_data,               & ! intent(in):    model prognostic variables for a local HRU
                       indx_data,               & ! intent(in):    index data
                       ! input-output: data structures
                       diag_data,               & ! intent(inout): model diagnostic variables for a local HRU
                       flux_data,               & ! intent(inout): model fluxes for a local HRU
                       deriv_data,              & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables
                       ! input-output: baseflow
                       ixSaturation,            & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration)
                       dBaseflow_dMatric,       & ! intent(out):   derivative in baseflow w.r.t. matric head (s-1)
                       ! output: flux and residual vectors
                       feasible,                & ! intent(out):   flag to denote the feasibility of the solution
                       fluxVec,                 & ! intent(out):   flux vector
                       resSink,                 & ! intent(out):   additional (sink) terms on the RHS of the state equation
                       resVec,                  & ! intent(out):   residual vector
                       fEval,                   & ! intent(out):   function evaluation
                       err,message)               ! intent(out):   error control
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! provide access to subroutines
 USE getVectorz_module, only:varExtract           ! extract variables from the state vector
 USE updateVars_module, only:updateVars           ! update prognostic variables
 USE computFlux_module, only:soilCmpres           ! compute soil compression
 USE computFlux_module, only:computFlux           ! compute fluxes given a state vector
 USE computResid_module,only:computResid          ! compute residuals given a state vector
 ! provide access to indices that define elements of the data structures
 USE var_lookup,only:iLookDECISIONS               ! named variables for elements of the decision structure
 USE var_lookup,only:iLookPARAM                   ! named variables for structure elements
 USE var_lookup,only:iLookPROG                    ! named variables for structure elements
 USE var_lookup,only:iLookINDEX                   ! named variables for structure elements
 USE var_lookup,only:iLookDIAG                    ! named variables for structure elements
 USE var_lookup,only:iLookDERIV                   ! named variables for structure elements
 implicit none
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! input: model control
 real(dp),intent(in)             :: dt                     ! length of the time step (seconds)
 integer(i4b),intent(in)         :: nSnow                  ! number of snow layers
 integer(i4b),intent(in)         :: nSoil                  ! number of soil layers
 integer(i4b),intent(in)         :: nLayers                ! total number of layers
 integer(i4b),intent(in)         :: nState                 ! total number of state variables
 logical(lgt),intent(in)         :: firstSubStep           ! flag to indicate if we are processing the first sub-step
 logical(lgt),intent(inout)      :: firstFluxCall          ! flag to indicate if we are processing the first flux call
 logical(lgt),intent(in)         :: firstSplitOper         ! flag to indicate if we are processing the first flux call in a splitting operation
 logical(lgt),intent(in)         :: computeVegFlux         ! flag to indicate if computing fluxes over vegetation
 ! input: state vectors
 real(dp),intent(in)             :: stateVecTrial(:)       ! model state vector
 real(dp),intent(in)             :: fScale(:)              ! function scaling vector
 real(qp),intent(in)             :: sMul(:)   ! NOTE: qp   ! state vector multiplier (used in the residual calculations)
 ! input: data structures
 type(model_options),intent(in)  :: model_decisions(:)     ! model decisions
 type(var_i),        intent(in)  :: type_data              ! type of vegetation and soil
 type(var_d),        intent(in)  :: attr_data              ! spatial attributes
 type(var_dlength),  intent(in)  :: mpar_data              ! model parameters
 type(var_d),        intent(in)  :: forc_data              ! model forcing data
 type(var_dlength),  intent(in)  :: bvar_data              ! model variables for the local basin
 type(var_dlength),  intent(in)  :: prog_data              ! prognostic variables for a local HRU
 type(var_ilength),  intent(in)  :: indx_data              ! indices defining model states and layers
 ! output: data structures
 type(var_dlength),intent(inout) :: diag_data              ! diagnostic variables for a local HRU
 type(var_dlength),intent(inout) :: flux_data              ! model fluxes for a local HRU
 type(var_dlength),intent(inout) :: deriv_data             ! derivatives in model fluxes w.r.t. relevant state variables
 ! input-output: baseflow
 integer(i4b),intent(inout)      :: ixSaturation           ! index of the lowest saturated layer (NOTE: only computed on the first iteration)
 real(dp),intent(out)            :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1)
 ! output: flux and residual vectors
 logical(lgt),intent(out)        :: feasible               ! flag to denote the feasibility of the solution
 real(dp),intent(out)            :: fluxVec(:)             ! flux vector
 real(dp),intent(out)            :: resSink(:)             ! sink terms on the RHS of the flux equation
 real(qp),intent(out)            :: resVec(:) ! NOTE: qp   ! residual vector
 real(dp),intent(out)            :: fEval                  ! function evaluation
 ! output: error control
 integer(i4b),intent(out)        :: err                    ! error code
 character(*),intent(out)        :: message                ! error message
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! local variables
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! state variables
 real(dp)                        :: scalarCanairTempTrial    ! trial value for temperature of the canopy air space (K)
 real(dp)                        :: scalarCanopyTempTrial    ! trial value for temperature of the vegetation canopy (K)
 real(dp)                        :: scalarCanopyWatTrial     ! trial value for liquid water storage in the canopy (kg m-2)
 real(dp),dimension(nLayers)     :: mLayerTempTrial          ! trial value for temperature of layers in the snow and soil domains (K)
 real(dp),dimension(nLayers)     :: mLayerVolFracWatTrial    ! trial value for volumetric fraction of total water (-)
 real(dp),dimension(nSoil)       :: mLayerMatricHeadTrial    ! trial value for total water matric potential (m)
 real(dp),dimension(nSoil)       :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m)
 ! diagnostic variables
 real(dp)                        :: scalarCanopyLiqTrial     ! trial value for mass of liquid water on the vegetation canopy (kg m-2)
 real(dp)                        :: scalarCanopyIceTrial     ! trial value for mass of ice on the vegetation canopy (kg m-2)
 real(dp),dimension(nLayers)     :: mLayerVolFracLiqTrial    ! trial value for volumetric fraction of liquid water (-)
 real(dp),dimension(nLayers)     :: mLayerVolFracIceTrial    ! trial value for volumetric fraction of ice (-)
 ! other local variables
 integer(i4b)                    :: iLayer                   ! index of model layer in the snow+soil domain
 integer(i4b),parameter          :: ixVegVolume=1            ! index of the desired vegetation control volumne (currently only one veg layer)
 real(dp)                        :: xMin,xMax                ! minimum and maximum values for water content
 real(dp)                        :: scalarCanopyHydTrial     ! trial value for mass of water on the vegetation canopy (kg m-2)
 real(dp),parameter              :: canopyTempMax=500._dp    ! expected maximum value for the canopy temperature (K)
 real(dp),dimension(nLayers)     :: mLayerVolFracHydTrial    ! trial value for volumetric fraction of water (-), general vector merged from Wat and Liq
 real(dp),dimension(nState)      :: rVecScaled               ! scaled residual vector
 character(LEN=256)              :: cmessage                 ! error message of downwind routine
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! association to variables in the data structures
 ! --------------------------------------------------------------------------------------------------------------------------------
 associate(&
 ! model decisions
 ixRichards              => model_decisions(iLookDECISIONS%f_Richards)%iDecision   ,&  ! intent(in):  [i4b]   index of the form of Richards' equation
 ! snow parameters
 snowfrz_scale           => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1)         ,&  ! intent(in):  [dp]    scaling parameter for the snow freezing curve (K-1)
 ! soil parameters
 theta_sat               => mpar_data%var(iLookPARAM%theta_sat)%dat                ,&  ! intent(in):  [dp(:)] soil porosity (-)
 specificStorage         => mpar_data%var(iLookPARAM%specificStorage)%dat(1)       ,&  ! intent(in):  [dp]    specific storage coefficient (m-1)
 ! canopy and layer depth
 canopyDepth             => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1)      ,&  ! intent(in):  [dp   ] canopy depth (m)
 mLayerDepth             => prog_data%var(iLookPROG%mLayerDepth)%dat               ,&  ! intent(in):  [dp(:)] depth of each layer in the snow-soil sub-domain (m)
 ! model state variables
 scalarSfcMeltPond       => prog_data%var(iLookPROG%scalarSfcMeltPond)%dat(1)      ,&  ! intent(in):  [dp]    ponded water caused by melt of the "snow without a layer" (kg m-2)
 mLayerVolFracIce        => prog_data%var(iLookPROG%mLayerVolFracIce)%dat          ,&  ! intent(in):  [dp(:)] volumetric fraction of ice (-)
 mLayerMatricHeadLiq     => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat       ,&  ! intent(in):  [dp(:)] liquid water matric potential (m)
 ! model diagnostic variables
 scalarFracLiqVeg        => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1)       ,&  ! intent(in):  [dp]    fraction of liquid water on vegetation (-)
 mLayerFracLiqSnow       => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat         ,&  ! intent(in):  [dp(:)] fraction of liquid water in each snow layer (-)
 mLayerPoreSpace         => diag_data%var(iLookDIAG%mLayerPoreSpace)%dat           ,&  ! intent(in):  [dp(:)] pore space in each snow layer (-)
 ! soil compression
 scalarSoilCompress      => diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1)     ,&  ! intent(in): [dp]    total change in storage associated with compression of the soil matrix (kg m-2)
 mLayerCompress          => diag_data%var(iLookDIAG%mLayerCompress)%dat            ,&  ! intent(in): [dp(:)] change in storage associated with compression of the soil matrix (-)
 ! derivatives
 dVolTot_dPsi0           => deriv_data%var(iLookDERIV%dVolTot_dPsi0)%dat           ,&  ! intent(in): [dp(:)] derivative in total water content w.r.t. total water matric potential
 dCompress_dPsi          => deriv_data%var(iLookDERIV%dCompress_dPsi)%dat          ,&  ! intent(in): [dp(:)] derivative in compressibility w.r.t. matric head (m-1)
 ! indices
 ixCasNrg                => indx_data%var(iLookINDEX%ixCasNrg)%dat(1)              ,&  ! intent(in): [i4b]    index of canopy air space energy state variable (nrg)
 ixVegNrg                => indx_data%var(iLookINDEX%ixVegNrg)%dat(1)              ,&  ! intent(in): [i4b]    index of canopy energy state variable (nrg)
 ixVegHyd                => indx_data%var(iLookINDEX%ixVegHyd)%dat(1)              ,&  ! intent(in): [i4b]    index of canopy hydrology state variable (mass)
 ixSnowOnlyNrg           => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat            ,&  ! intent(in): [i4b(:)] indices for energy states in the snow subdomain
 ixSnowSoilHyd           => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat            ,&  ! intent(in): [i4b(:)] indices for hydrology states in the snow+soil subdomain
 ixStateType             => indx_data%var(iLookINDEX%ixStateType)%dat              ,&  ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...)
 ixHydCanopy             => indx_data%var(iLookINDEX%ixHydCanopy)%dat              ,&  ! intent(in): [i4b(:)] index of the hydrology states in the canopy domain
 ixHydType               => indx_data%var(iLookINDEX%ixHydType)%dat                ,&  ! intent(in): [i4b(:)] index of the type of hydrology states in snow+soil domain
 layerType               => indx_data%var(iLookINDEX%layerType)%dat                 &  ! intent(in): [i4b(:)] layer type (iname_soil or iname_snow)
 ) ! association to variables in the data structures
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! initialize error control
 err=0; message="eval8summa/"

 ! check the feasibility of the solution
 feasible=.true.

 ! check that the canopy air space temperature is reasonable
 if(ixCasNrg/=integerMissing)then
  if(stateVecTrial(ixCasNrg) > canopyTempMax) feasible=.false.
 endif

 ! check that the canopy air space temperature is reasonable
 if(ixVegNrg/=integerMissing)then
  if(stateVecTrial(ixVegNrg) > canopyTempMax) feasible=.false.
 endif

 ! check canopy liquid water is not negative
 if(ixVegHyd/=integerMissing)then
  if(stateVecTrial(ixVegHyd) < 0._dp) feasible=.false.
 end if

 ! check snow temperature is below freezing
 if(count(ixSnowOnlyNrg/=integerMissing)>0)then
  if(any(stateVecTrial( pack(ixSnowOnlyNrg,ixSnowOnlyNrg/=integerMissing) ) > Tfreeze)) feasible=.false.
 endif

 ! loop through non-missing hydrology state variables in the snow+soil domain
 do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing)

  ! check the minimum and maximum water constraints
  if(ixHydType(iLayer)==iname_watLayer .or. ixHydType(iLayer)==iname_liqLayer)then

   ! --> minimum
   if (layerType(iLayer) == iname_soil) then
    xMin = theta_sat(iLayer-nSnow)
   else
    xMin = 0._dp
   endif

   ! --> maximum
   select case( layerType(iLayer) )
    case(iname_snow); xMax = merge(iden_ice,  mLayerPoreSpace(iLayer), ixHydType(iLayer)==iname_watLayer)
    case(iname_soil); xMax = merge(theta_sat(iLayer-nSnow), theta_sat(iLayer-nSnow) - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer)
   end select

   ! --> check
   if(stateVecTrial( ixSnowSoilHyd(iLayer) ) < xMin .or. stateVecTrial( ixSnowSoilHyd(iLayer) ) > xMax) feasible=.false.
   !if(.not.feasible) write(*,'(a,1x,i4,1x,L1,1x,10(f20.10,1x))') 'iLayer, feasible, stateVecTrial( ixSnowSoilHyd(iLayer) ), xMin, xMax = ', iLayer, feasible, stateVecTrial( ixSnowSoilHyd(iLayer) ), xMin, xMax

  endif  ! if water states

 end do  ! loop through non-missing hydrology state variables in the snow+soil domain

 ! early return for non-feasible solutions
 if(.not.feasible)then
  fluxVec(:) = realMissing
  resVec(:)  = quadMissing
  fEval      = realMissing
  return
 end if

 ! extract variables from the model state vector
 call varExtract(&
                 ! input
                 stateVecTrial,            & ! intent(in):    model state vector (mixed units)
                 diag_data,                & ! intent(in):    model diagnostic variables for a local HRU
                 prog_data,                & ! intent(in):    model prognostic variables for a local HRU
                 indx_data,                & ! intent(in):    indices defining model states and layers
                 ! output: variables for the vegetation canopy
                 scalarCanairTempTrial,    & ! intent(out):   trial value of canopy air temperature (K)
                 scalarCanopyTempTrial,    & ! intent(out):   trial value of canopy temperature (K)
                 scalarCanopyWatTrial,     & ! intent(out):   trial value of canopy total water (kg m-2)
                 scalarCanopyLiqTrial,     & ! intent(out):   trial value of canopy liquid water (kg m-2)
                 scalarCanopyIceTrial,     & ! intent(out):   trial value of canopy ice content (kg m-2)
                 ! output: variables for the snow-soil domain
                 mLayerTempTrial,          & ! intent(out):   trial vector of layer temperature (K)
                 mLayerVolFracWatTrial,    & ! intent(out):   trial vector of volumetric total water content (-)
                 mLayerVolFracLiqTrial,    & ! intent(out):   trial vector of volumetric liquid water content (-)
                 mLayerVolFracIceTrial,    & ! intent(out):   trial vector of volumetric ice water content (-)
                 mLayerMatricHeadTrial,    & ! intent(out):   trial vector of total water matric potential (m)
                 mLayerMatricHeadLiqTrial, & ! intent(out):   trial vector of liquid water matric potential (m)
                 ! output: error control
                 err,cmessage)               ! intent(out):   error control
 if(err/=0)then; message=trim(message)//trim(cmessage); return; end if  ! (check for errors)

 ! update diagnostic variables
 call updateVars(&
                 ! input
                 .false.,                                   & ! intent(in):    logical flag to adjust temperature to account for the energy used in melt+freeze
                 .false.,                                   & ! intent(in):    logical flag to denote the need for the explicit Euler update
                 mpar_data,                                 & ! intent(in):    model parameters for a local HRU
                 indx_data,                                 & ! intent(in):    indices defining model states and layers
                 prog_data,                                 & ! intent(in):    model prognostic variables for a local HRU
                 diag_data,                                 & ! intent(inout): model diagnostic variables for a local HRU
                 deriv_data,                                & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables
                 ! output: variables for the vegetation canopy
                 scalarCanopyTempTrial,                     & ! intent(inout): trial value of canopy temperature (K)
                 scalarCanopyWatTrial,                      & ! intent(inout): trial value of canopy total water (kg m-2)
                 scalarCanopyLiqTrial,                      & ! intent(inout): trial value of canopy liquid water (kg m-2)
                 scalarCanopyIceTrial,                      & ! intent(inout): trial value of canopy ice content (kg m-2)
                 ! output: variables for the snow-soil domain
                 mLayerTempTrial,                           & ! intent(inout): trial vector of layer temperature (K)
                 mLayerVolFracWatTrial,                     & ! intent(inout): trial vector of volumetric total water content (-)
                 mLayerVolFracLiqTrial,                     & ! intent(inout): trial vector of volumetric liquid water content (-)
                 mLayerVolFracIceTrial,                     & ! intent(inout): trial vector of volumetric ice water content (-)
                 mLayerMatricHeadTrial,                     & ! intent(inout): trial vector of total water matric potential (m)
                 mLayerMatricHeadLiqTrial,                  & ! intent(inout): trial vector of liquid water matric potential (m)
                 ! output: error control
                 err,cmessage)                                ! intent(out):   error control
 if(err/=0)then; message=trim(message)//trim(cmessage); return; end if  ! (check for errors)

 ! print the states in the canopy domain
 !print*, 'dt = ', dt
 !write(*,'(a,1x,10(f20.10,1x))') 'scalarCanopyTempTrial    = ', scalarCanopyTempTrial
 !write(*,'(a,1x,10(f20.10,1x))') 'scalarCanopyWatTrial     = ', scalarCanopyWatTrial
 !write(*,'(a,1x,10(f20.10,1x))') 'scalarCanopyLiqTrial     = ', scalarCanopyLiqTrial
 !write(*,'(a,1x,10(f20.10,1x))') 'scalarCanopyIceTrial     = ', scalarCanopyIceTrial

 ! print the states in the snow+soil domain
 !write(*,'(a,1x,10(f20.10,1x))') 'mLayerTempTrial          = ', mLayerTempTrial(iJac1:min(nLayers,iJac2))
 !write(*,'(a,1x,10(f20.10,1x))') 'mLayerVolFracWatTrial    = ', mLayerVolFracWatTrial(iJac1:min(nLayers,iJac2))
 !write(*,'(a,1x,10(f20.10,1x))') 'mLayerVolFracLiqTrial    = ', mLayerVolFracLiqTrial(iJac1:min(nLayers,iJac2))
 !write(*,'(a,1x,10(f20.10,1x))') 'mLayerVolFracIceTrial    = ', mLayerVolFracIceTrial(iJac1:min(nLayers,iJac2))
 !write(*,'(a,1x,10(f20.10,1x))') 'mLayerMatricHeadTrial    = ', mLayerMatricHeadTrial(iJac1:min(nSoil,iJac2))
 !write(*,'(a,1x,10(f20.10,1x))') 'mLayerMatricHeadLiqTrial = ', mLayerMatricHeadLiqTrial(iJac1:min(nSoil,iJac2))

 ! print the water content
 if(globalPrintFlag)then
  if(iJac1<nSnow) write(*,'(a,10(f16.10,1x))') 'mLayerVolFracWatTrial = ', mLayerVolFracWatTrial(iJac1:min(iJac2,nSnow))
  if(iJac1<nSnow) write(*,'(a,10(f16.10,1x))') 'mLayerVolFracLiqTrial = ', mLayerVolFracLiqTrial(iJac1:min(iJac2,nSnow))
  if(iJac1<nSnow) write(*,'(a,10(f16.10,1x))') 'mLayerVolFracIceTrial = ', mLayerVolFracIceTrial(iJac1:min(iJac2,nSnow))
 endif

 ! compute the fluxes for a given state vector
 call computFlux(&
                 ! input-output: model control
                 nSnow,                   & ! intent(in):    number of snow layers
                 nSoil,                   & ! intent(in):    number of soil layers
                 nLayers,                 & ! intent(in):    total number of layers
                 firstSubStep,            & ! intent(in):    flag to indicate if we are processing the first sub-step
                 firstFluxCall,           & ! intent(inout): flag to denote the first flux call
                 firstSplitOper,          & ! intent(in):    flag to indicate if we are processing the first flux call in a splitting operation
                 computeVegFlux,          & ! intent(in):    flag to indicate if we need to compute fluxes over vegetation
                 scalarSfcMeltPond/dt,    & ! intent(in):    drainage from the surface melt pond (kg m-2 s-1)
                 ! input: state variables
                 scalarCanairTempTrial,   & ! intent(in):    trial value for the temperature of the canopy air space (K)
                 scalarCanopyTempTrial,   & ! intent(in):    trial value for the temperature of the vegetation canopy (K)
                 mLayerTempTrial,         & ! intent(in):    trial value for the temperature of each snow and soil layer (K)
                 mLayerMatricHeadLiqTrial,& ! intent(in):    trial value for the liquid water matric potential in each soil layer (m)
                 ! input: diagnostic variables defining the liquid water and ice content
                 scalarCanopyLiqTrial,    & ! intent(in):    trial value for the liquid water on the vegetation canopy (kg m-2)
                 scalarCanopyIceTrial,    & ! intent(in):    trial value for the ice on the vegetation canopy (kg m-2)
                 mLayerVolFracLiqTrial,   & ! intent(in):    trial value for the volumetric liquid water content in each snow and soil layer (-)
                 mLayerVolFracIceTrial,   & ! intent(in):    trial value for the volumetric ice in each snow and soil layer (-)
                 ! input: data structures
                 model_decisions,         & ! intent(in):    model decisions
                 type_data,               & ! intent(in):    type of vegetation and soil
                 attr_data,               & ! intent(in):    spatial attributes
                 mpar_data,               & ! intent(in):    model parameters
                 forc_data,               & ! intent(in):    model forcing data
                 bvar_data,               & ! intent(in):    average model variables for the entire basin
                 prog_data,               & ! intent(in):    model prognostic variables for a local HRU
                 indx_data,               & ! intent(in):    index data
                 ! input-output: data structures
                 diag_data,               & ! intent(inout): model diagnostic variables for a local HRU
                 flux_data,               & ! intent(inout): model fluxes for a local HRU
                 deriv_data,              & ! intent(out):   derivatives in model fluxes w.r.t. relevant state variables
                 ! input-output: flux vector and baseflow derivatives
                 ixSaturation,            & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration)
                 dBaseflow_dMatric,       & ! intent(out):   derivative in baseflow w.r.t. matric head (s-1)
                 fluxVec,                 & ! intent(out):   flux vector (mixed units)
                 ! output: error control
                 err,cmessage)              ! intent(out):   error code and error message
 if(err/=0)then; message=trim(message)//trim(cmessage); return; end if  ! (check for errors)

 ! compute soil compressibility (-) and its derivative w.r.t. matric head (m)
 ! NOTE: we already extracted trial matrix head and volumetric liquid water as part of the flux calculations
 call soilCmpres(&
                 ! input:
                 ixRichards,                             & ! intent(in): choice of option for Richards' equation
                 mLayerMatricHeadLiq(1:nSoil),           & ! intent(in): matric head at the start of the time step (m)
                 mLayerMatricHeadLiqTrial(1:nSoil),      & ! intent(in): trial value of matric head (m)
                 mLayerVolFracLiqTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-)
                 mLayerVolFracIceTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric ice content in each soil layer (-)
                 dVolTot_dPsi0,                          & ! intent(in): derivative in the soil water characteristic (m-1)
                 specificStorage,                        & ! intent(in): specific storage coefficient (m-1)
                 theta_sat,                              & ! intent(in): soil porosity (-)
                 ! output:
                 mLayerCompress,                         & ! intent(out): compressibility of the soil matrix (-)
                 dCompress_dPsi,                         & ! intent(out): derivative in compressibility w.r.t. matric head (m-1)
                 err,cmessage)                             ! intent(out): error code and error message
 if(err/=0)then; message=trim(message)//trim(cmessage); return; end if  ! (check for errors)

 ! compute the total change in storage associated with compression of the soil matrix (kg m-2)
 scalarSoilCompress = sum(mLayerCompress(1:nSoil)*mLayerDepth(nSnow+1:nLayers))*iden_water

 ! vegetation domain: get the correct water states (total water, or liquid water, depending on the state type)
 if(computeVegFlux)then
  scalarCanopyHydTrial = merge(scalarCanopyWatTrial, scalarCanopyLiqTrial, (ixStateType( ixHydCanopy(ixVegVolume) )==iname_watCanopy) )
 else
  scalarCanopyHydTrial = realMissing
 endif

 ! snow+soil domain: get the correct water states (total water, or liquid water, depending on the state type)
 mLayerVolFracHydTrial = merge(mLayerVolFracWatTrial, mLayerVolFracLiqTrial, (ixHydType==iname_watLayer .or. ixHydType==iname_matLayer) )

 ! compute the residual vector
 call computResid(&
                  ! input: model control
                  dt,                      & ! intent(in):    length of the time step (seconds)
                  nSnow,                   & ! intent(in):    number of snow layers
                  nSoil,                   & ! intent(in):    number of soil layers
                  nLayers,                 & ! intent(in):    total number of layers
                  ! input: flux vectors
                  sMul,                    & ! intent(in):    state vector multiplier (used in the residual calculations)
                  fluxVec,                 & ! intent(in):    flux vector
                  ! input: state variables (already disaggregated into scalars and vectors)
                  scalarCanairTempTrial,   & ! intent(in):    trial value for the temperature of the canopy air space (K)
                  scalarCanopyTempTrial,   & ! intent(in):    trial value for the temperature of the vegetation canopy (K)
                  scalarCanopyHydTrial,    & ! intent(in):    trial value of canopy hydrology state variable (kg m-2)
                  mLayerTempTrial,         & ! intent(in):    trial value for the temperature of each snow and soil layer (K)
                  mLayerVolFracHydTrial,   & ! intent(in):    trial vector of volumetric water content (-)
                  ! input: diagnostic variables defining the liquid water and ice content (function of state variables)
                  scalarCanopyIceTrial,    & ! intent(in):    trial value for the ice on the vegetation canopy (kg m-2)
                  mLayerVolFracIceTrial,   & ! intent(in):    trial value for the volumetric ice in each snow and soil layer (-)
                  ! input: data structures
                  prog_data,               & ! intent(in):    model prognostic variables for a local HRU
                  diag_data,               & ! intent(in):    model diagnostic variables for a local HRU
                  flux_data,               & ! intent(in):    model fluxes for a local HRU
                  indx_data,               & ! intent(in):    index data
                  ! output
                  resSink,                 & ! intent(out):   additional (sink) terms on the RHS of the state equation
                  resVec,                  & ! intent(out):   residual vector
                  err,cmessage)              ! intent(out):   error control
 if(err/=0)then; message=trim(message)//trim(cmessage); return; end if  ! (check for errors)

 ! compute the function evaluation
 rVecScaled = fScale(:)*real(resVec(:), dp)   ! scale the residual vector (NOTE: residual vector is in quadruple precision)
 fEval      = 0.5_dp*dot_product(rVecScaled,rVecScaled)

 ! end association with the information in the data structures
 end associate

 end subroutine eval8summa
end module eval8summa_module


c
c   Dint – version 2.0  is licensed under the Apache License, Version 2.0 (the "License");
c   you may not use Dint – version 2.0 except in compliance with the License.
c   You may obtain a copy of the License at
c       http://www.apache.org/licenses/LICENSE-2.0
c   The license is also given in the LICENSE file.
c   Unless required by applicable law or agreed to in writing, software
c   distributed under the License is distributed on an "AS IS" BASIS,
c   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
c   See the License for the specific language governing permissions and limitations under the License.
c
c -------------------------------------------------------------------------------------------
c  Dint : Direct Nonadiabatic Trajectories A code for non-Born–Oppenheimer molecular dynamics
c
c  version 2.0
c
c  A. W. Jasper
c  Argonne National Laboratory
c
c  Rui Ming Zhang
c  Tsinghua University
c
c  and
c
c  D. G. Truhlar
c  University of Minnesota
c
c  copyright  2020
c  Donald G. Truhlar and Regents of the University of Minnesota
c----------------------------------------------------------------------------------------------

      subroutine preptraj

c Put center of mass at origin

      implicit none
      include 'param.f'
      include 'c_traj.f'
      include 'c_sys.f'

      double precision xtot,ytot,ztot,mtot

      integer i
      call gettemp(pp,mm,nat,temp,ke)
      write(6,*)"Calculated temp = ",temp," K"
      write(6,*)"Total KE        = ",ke*autoev," eV"
      write(6,*)

      xtot=0.d0
      ytot=0.d0
      ztot=0.d0
      mtot=0.d0
      do i=1,nat
          xtot = xtot + mm(i)*xx(1,i)
          ytot = ytot + mm(i)*xx(2,i)
          ztot = ztot + mm(i)*xx(3,i)
          mtot = mtot + mm(i)
      enddo
      do i=1,nat
          xx(1,i) = xx(1,i) - xtot/mtot
          xx(2,i) = xx(2,i) - ytot/mtot
          xx(3,i) = xx(3,i) - ztot/mtot
      enddo

      call gettemp(pp,mm,nat,temp,ke)
      write(6,*)"Placed CoM at origin"
      write(6,*)"Calculated temp = ",temp," K"
      write(6,*)"Total KE        = ",ke*autoev," eV"
      write(6,*)

c     remove overall momenta
      xtot=0.d0
      ytot=0.d0
      ztot=0.d0
      mtot=0.d0
      do i=1,nat
        xtot=xtot+pp(1,i)
        ytot=ytot+pp(2,i)
        ztot=ztot+pp(3,i)
        mtot = mtot + mm(i)
      enddo
      do i=1,nat
        pp(1,i)=pp(1,i)-xtot*mm(i)/mtot
        pp(2,i)=pp(2,i)-ytot*mm(i)/mtot
        pp(3,i)=pp(3,i)-ztot*mm(i)/mtot
      enddo
      call gettemp(pp,mm,nat,temp,ke)
      write(6,*)"Removed CoM motion"
      write(6,*)"Calculated temp = ",temp," K"
      write(6,*)"Total KE        = ",ke*autoev," eV"
      write(6,*)

      return

      end


      subroutine mgt_sched (isched)

      use plant_data_module
      use mgt_operations_module
      use tillage_data_module
      use basin_module
      use hydrograph_module
      use hru_module, only : hru, ihru, phubase, ndeat, igrz, grz_days,    &
        yr_skip, sol_sumno3, sol_sumsolp, fertnh3, fertno3, fertorgn,  &
        fertorgp, fertsolp, ipl, sweepeff, yr_skip, yield
      use soil_module
      use plant_module
      use time_module
      use constituent_mass_module
      use organic_mineral_mass_module
      use calibration_data_module

      implicit none

      integer :: icom              !         |
      integer :: idp               !         |
      integer :: j                 !none     |counter
      integer :: iharvop           !         |harvest operation type
      integer :: idtill            !none     |tillage type
      integer :: ifrt              !         |fertilizer type from fert data base
      integer :: iob               !         |
      integer :: ipestcom          !none     |counter
      integer :: ipest             !none     |sequential pesticide type from pest community
      integer :: ipestop           !none     |surface application fraction from chem app data base
      integer :: irrop             !none     |irrigation ops data base pointer
      integer :: jj                !none     |counter
      integer :: isched            !         |
      integer :: iburn             !none     |burn type from fire data base
      integer :: ifertop           !frac     |surface application fraction from chem app data base
      integer :: iplt_bsn
      integer :: ireg
      integer :: ilum
      real :: fr_curb              !none     |availability factor, the fraction of the
                                   !         |curb length that is sweepable
      real :: biomass              !         |
      real :: amt_mm               !         |
      real :: frt_kg               !kg/ha    |amount of fertilizer applied
      real :: pest_kg              !kg/ha    |amount of pesticide applied

      j = ihru

      ! determine which plant in community (%op2)
      if (mgt%op /= "fert      ") then
        mgt%op2 = 0
        icom = pcom(j)%pcomdb
        if (icom > 0) then
          if (pcom(j)%npl > 1) then
            do ipl = 1, pcom(j)%npl
              if (mgt%op_char == pcomdb(icom)%pl(ipl)%cpnm) then
                mgt%op2 = ipl
                exit
              end if
            end do
          end if
        end if
      end if

      select case (mgt%op)

          case ("plnt")    !! plant one plant or entire community
            icom = pcom(j)%pcomdb
            pcom(j)%days_plant = 1       !reset days since last plant
            do ipl = 1, pcom(j)%npl
              idp = pcomdb(icom)%pl(ipl)%db_num
              if (mgt%op_char == pcomdb(icom)%pl(ipl)%cpnm) then
                pcom(j)%plcur(ipl)%gro = "y"
                pcom(j)%plcur(ipl)%idorm = "n"
                if (pco%mgtout ==  "y") then
                  write (2612, *) j, time%yrc, time%mo, time%day_mo, pldb(idp)%plantnm,  "PLANT ", &
                      phubase(j), pcom(j)%plcur(ipl)%phuacc,  soil(j)%sw,                          &
                      pl_mass(j)%tot(ipl)%m, rsd1(j)%tot_com%m, sol_sumno3(j),                     &
                      sol_sumsolp(j),pcom(j)%plg(ipl)%lai, pcom(j)%plcur(ipl)%lai_pot
                end if
              end if
            end do

          case ("mons")  !! begin and end monsoon initiation period
            !!begin monsoon initiation period
            if (int(mgt%op3) == 1) then
              pcom(j)%mseas = 1
              do ipl = 1, pcom(j)%npl
                pcom(j)%plcur(ipl)%monsoon_init = 1
              end do
            else
              pcom(j)%mseas = 0
             do ipl = 1, pcom(j)%npl
               if (pcom(j)%plcur(ipl)%monsoon_init == 1) then
                  pcom(j)%plcur(ipl)%gro = "y"
                  pcom(j)%plcur(ipl)%phuacc = 0.
                  pcom(j)%plcur(ipl)%idorm = "n"
                  pcom(j)%plcur(ipl)%monsoon_init = 0
               endif
            end do
            end if

          case ("harv")  !! harvest only operation
            iharvop = mgt%op1

            do ipl = 1, pcom(j)%npl
              if (pcom(j)%plcur(ipl)%gro == "y") then
              biomass = pl_mass(j)%tot(ipl)%m
              if (mgt%op_char == pcomdb(icom)%pl(ipl)%cpnm .or. mgt%op_char == "all") then
                pcom(j)%days_harv = 1       !reset days since last harvest

                !harvest specific type
                select case (harvop_db(iharvop)%typ)
                case ("biomass")
                  call mgt_harvbiomass (j, ipl, iharvop)
                case ("grain")
                  call mgt_harvgrain (j, ipl, iharvop)
                case ("residue")
                case ("tree")
                case ("tuber")
                  call mgt_harvtuber (j, ipl, iharvop)
                case ("peanuts")
                  call mgt_harvtuber (j, ipl, iharvop)
                case ("stripper")
                  call mgt_harvgrain (j, ipl, iharvop)
                case ("picker")
                  call mgt_harvgrain (j, ipl, iharvop)
                end select

                !! sum yield and number of harvest to calc ave yields
                pl_mass(j)%yield_tot(ipl) = pl_mass(j)%yield_tot(ipl) + pl_yield
                pcom(j)%plcur(ipl)%harv_num = pcom(j)%plcur(ipl)%harv_num + 1

                !! sum basin crop yields and area harvested
                iplt_bsn = pcom(j)%plcur(ipl)%bsn_num
                bsn_crop_yld(iplt_bsn)%area_ha = bsn_crop_yld(iplt_bsn)%area_ha + hru(j)%area_ha
                bsn_crop_yld(iplt_bsn)%yield = bsn_crop_yld(iplt_bsn)%yield + pl_yield%m * hru(j)%area_ha / 1000.
                !! sum regional crop yields for soft calibration
                if (hru(j)%crop_reg > 0) then
                  ireg = hru(j)%crop_reg
                  do ilum = 1, plcal(ireg)%lum_num
                    if (plcal(ireg)%lum(ilum)%meas%name == mgt%op_char) then
                      plcal(ireg)%lum(ilum)%ha = plcal(ireg)%lum(ilum)%ha + hru(j)%area_ha
                      plcal(ireg)%lum(ilum)%sim%yield = plcal(ireg)%lum(ilum)%sim%yield + pl_yield%m * hru(j)%area_ha / 1000.
                    end if
                  end do
                end if

                idp = pcom(j)%plcur(ipl)%idplt
                if (pco%mgtout == "y") then
                  write (2612, *) j, time%yrc, time%mo, time%day_mo,  pldb(idp)%plantnm, "HARVEST ",    &
                      phubase(j), pcom(j)%plcur(ipl)%phuacc, soil(j)%sw, biomass, rsd1(j)%tot(ipl)%m,   &
                      sol_sumno3(j), sol_sumsolp(j), pl_yield%m, pcom(j)%plstr(ipl)%sum_n,              &
                      pcom(j)%plstr(ipl)%sum_p, pcom(j)%plstr(ipl)%sum_tmp, pcom(j)%plstr(ipl)%sum_w,   &
                      pcom(j)%plstr(ipl)%sum_a
                end if
              end if
              pcom(j)%plcur(ipl)%phuacc = 0.
              end if
            end do

            case ("kill")   !! kill operation
              do ipl = 1, pcom(j)%npl
                biomass = pl_mass(j)%tot(ipl)%m
                if (mgt%op_char == pcomdb(icom)%pl(ipl)%cpnm .or. mgt%op_char == "all") then
                  call mgt_killop (j, ipl)

                  idp = pcom(j)%plcur(ipl)%idplt
                  if (pco%mgtout == "y") then
                    write (2612, *) j, time%yrc, time%mo, time%day_mo,  pldb(idp)%plantnm, "    KILL ",  &
                      phubase(j), pcom(j)%plcur(ipl)%phuacc, soil(j)%sw, biomass, rsd1(j)%tot(ipl)%m,   &
                      sol_sumno3(j), sol_sumsolp(j), pl_yield%m, pcom(j)%plstr(ipl)%sum_n,              &
                      pcom(j)%plstr(ipl)%sum_p, pcom(j)%plstr(ipl)%sum_tmp, pcom(j)%plstr(ipl)%sum_w,   &
                      pcom(j)%plstr(ipl)%sum_a
                  end if
                end if
                pcom(j)%plcur(ipl)%phuacc = 0.
              end do

          case ("hvkl")   !! harvest and kill operation
            iharvop = mgt%op1

            do ipl = 1, pcom(j)%npl
              biomass = pl_mass(j)%tot(ipl)%m
              if (mgt%op_char == pcomdb(icom)%pl(ipl)%cpnm .or. mgt%op_char == "all") then
                pcom(j)%days_harv = 1       !reset days since last harvest

                !harvest specific type
                select case (harvop_db(iharvop)%typ)
                case ("biomass")
                  call mgt_harvbiomass (j, ipl, iharvop)
                case ("grain")
                  call mgt_harvgrain (j, ipl, iharvop)
                case ("residue")
                case ("tree")
                case ("tuber")
                end select

                call mgt_killop (j, ipl)

                !! sum yield and num. of harvest to calc ave yields
                pl_mass(j)%yield_tot(ipl) = pl_mass(j)%yield_tot(ipl) + pl_yield
                pcom(j)%plcur(ipl)%harv_num = pcom(j)%plcur(ipl)%harv_num + 1

                !! sum basin crop yields and area harvested
                iplt_bsn = pcom(j)%plcur(ipl)%bsn_num
                bsn_crop_yld(iplt_bsn)%area_ha = bsn_crop_yld(iplt_bsn)%area_ha + hru(j)%area_ha
                bsn_crop_yld(iplt_bsn)%yield = bsn_crop_yld(iplt_bsn)%yield + yield * hru(j)%area_ha / 1000.
                !! sum regional crop yields for soft calibration
                ireg = hru(j)%crop_reg
                do ilum = 1, plcal(ireg)%lum_num
                  if (plcal(ireg)%lum(ilum)%meas%name == mgt%op_char) then
                    plcal(ireg)%lum(ilum)%ha = plcal(ireg)%lum(ilum)%ha + hru(j)%area_ha
                    plcal(ireg)%lum(ilum)%sim%yield = plcal(ireg)%lum(ilum)%sim%yield + pl_yield%m * hru(j)%area_ha / 1000.
                  end if
                end do

                idp = pcom(j)%plcur(ipl)%idplt
                if (pco%mgtout == "y") then
                  write (2612, *) j, time%yrc, time%mo, time%day_mo,  pldb(idp)%plantnm, "HARV/KILL ",          &
                      phubase(j), pcom(j)%plcur(ipl)%phuacc, soil(j)%sw, biomass, rsd1(j)%tot(ipl)%m,           &
                      sol_sumno3(j), sol_sumsolp(j), pl_mass(j)%yield_tot(ipl)%m, pcom(j)%plstr(ipl)%sum_n,     &
                      pcom(j)%plstr(ipl)%sum_p, pcom(j)%plstr(ipl)%sum_tmp, pcom(j)%plstr(ipl)%sum_w,           &
                      pcom(j)%plstr(ipl)%sum_a
                end if
              end if
              pcom(j)%plstr(ipl) = plstrz
              pcom(j)%plcur(ipl)%phuacc = 0.
              phubase(j) = 0.
            end do

          case ("till")   !! tillage operation
            idtill = mgt%op1
            ipl = Max(1, mgt%op2)
            call mgt_newtillmix(j, 0., idtill)

            if (pco%mgtout == "y") then
              write (2612, *) j, time%yrc, time%mo, time%day_mo, tilldb(idtill)%tillnm, "TILLAGE ", &
                  phubase(j), pcom(j)%plcur(ipl)%phuacc, soil(j)%sw, pl_mass(j)%tot(ipl)%m,         &
                  rsd1(j)%tot(ipl)%m, sol_sumno3(j), sol_sumsolp(j), tilldb(idtill)%effmix
            end if

          case ("irrm")  !! date scheduled irrigation operation
            ipl = 1
            irrop = mgt%op4                        !irrigation amount (mm) from irr.ops data base
            irrig(j)%applied = irrop_db(irrop)%amt_mm * irrop_db(irrop)%eff * (1. - irrop_db(irrop)%surq)
            irrig(j)%runoff = irrop_db(irrop)%amt_mm * irrop_db(irrop)%surq

            !print irrigation applied
            if (pco%mgtout == "y") then
              write (2612, *) j, time%yrc, time%mo, time%day_mo, "        ", "IRRIGATE ", phubase(j),   &
                  pcom(j)%plcur(ipl)%phuacc, soil(j)%sw,pl_mass(j)%tot(ipl)%m, rsd1(j)%tot(ipl)%m,      &
                  sol_sumno3(j), sol_sumsolp(j), irrig(j)%applied, irrig(j)%runoff
            end if

          case ("fert")   !! fertilizer operation
            ipl = 1
            ifrt = mgt%op1                          !fertilizer type from fert data base
            frt_kg = mgt%op3                        !amount applied in kg/ha
            ifertop = mgt%op4                       !surface application fraction from chem app data base
            call pl_fert (j, ifrt, frt_kg, ifertop)

            if (pco%mgtout == "y") then
              write (2612,*) j, time%yrc, time%mo, time%day_mo, mgt%op_char, "    FERT ", &
                phubase(j), pcom(j)%plcur(ipl)%phuacc, soil(j)%sw, pl_mass(j)%tot(ipl)%m,           &
                rsd1(j)%tot_com%m, sol_sumno3(j), sol_sumsolp(j), frt_kg, fertno3, fertnh3,         &
                fertorgn, fertsolp, fertorgp
            endif

          case ("pest")   !! pesticide operation
            !xwalk application in the mgt file with the pest community
            iob = sp_ob%hru + ihru - 1
            do ipestcom = 1, cs_db%num_pests
              if (cs_db%pests(ipestcom) == mgt%op_char) then
                mgt%op1 = ipestcom
                exit
              end if
            end do

            ipl = 1
            ipest = mgt%op1                                     !sequential pesticide type from pest community
            ipestop = mgt%op4                                   !surface application option from chem app data base
            pest_kg = mgt%op3 * chemapp_db(ipestop)%app_eff    !amount applied in kg/ha
            call pest_apply (j, ipest, pest_kg, ipestop)

            if (pco%mgtout == "y") then
              write (2612, *) j, time%yrc, time%mo, time%day_mo, mgt%op_char, "    PEST ", &
                phubase(j), pcom(j)%plcur(ipl)%phuacc, soil(j)%sw,pl_mass(j)%tot(ipl)%m,   &
                rsd1(j)%tot(ipl)%m, sol_sumno3(j), sol_sumsolp(j), pest_kg
            endif

          case ("graz")    !! grazing operation
            ndeat(j) = 0
            igrz(j) = 1
            ipl = Max(1, mgt%op2)
            grz_days(j) = mgt%op3
            graze = grazeop_db(mgt%op1)

            !if (pco%mgtout == "y") then
            !  write (2612, *) j, time%yrc, time%mo, time%day_mo, "         ", "    GRAZE ",         &
            !    phubase(j), pcom(j)%plcur(ipl)%phuacc, soil(j)%sw,pl_mass(j)%tot(ipl)%m,        &
            !    rsd1(j)%tot(ipl)%m, sol_sumno3(j), sol_sumsolp(j), grazeop_db(mgt%op1)%eat, grazeop_db(mgt%op1)%manure
            !endif

          case ("burn")   !! burning
            iburn = mgt%op1                 !burn type from fire data base
            do ipl = 1, pcom(j)%npl
              call pl_burnop (j, ipl, iburn)
            end do

            if (pco%mgtout == "y") then
              write (2612, *) j, time%yrc, time%mo, time%day_mo, "        ", "    BURN ", phubase(j),   &
                  pcom(j)%plcur(ipl)%phuacc, soil(j)%sw,pl_mass(j)%tot(ipl)%m, rsd1(j)%tot(ipl)%m,      &
                  sol_sumno3(j), sol_sumsolp(j)
            end if

          case ("swep")   !! street sweeping (only if iurban=2)
            ipl = Max(1, mgt%op2)
            sweepop = sweepop_db(mgt%op1)
            sweepeff = sweepop%eff
            fr_curb = sweepop%fr_curb

            if (pco%mgtout == "y") then
              write (2612, *) j, time%yrc, time%mo, time%day_mo, "        ", "STREET SWEEP ", phubase(j),    &
                  pcom(j)%plcur(ipl)%phuacc, soil(j)%sw, pl_mass(j)%tot(ipl)%m, rsd1(j)%tot(ipl)%m,          &
                  sol_sumno3(j), sol_sumsolp(j)
            end if

          case ("dwm")    !! set drain depth for drainage water management
            hru(j)%lumv%sdr_dep = mgt%op3
            if (hru(j)%lumv%sdr_dep > 0) then
              do jj = 1, soil(ihru)%nly
                if (hru(j)%lumv%sdr_dep < soil(ihru)%phys(jj)%d) hru(ihru)%lumv%ldrain = jj
                if (hru(j)%lumv%sdr_dep < soil(ihru)%phys(jj)%d) exit
              end do
            else
                hru(ihru)%lumv%ldrain = 0
            endif
            !! added below changed plcur(ipl) to plcur(j) and plm(ipl) to plm(j) gsm 1/30/2018
            if (pco%mgtout ==  "y") then
              write (2612, *) j, time%yrc, time%mo, time%day_mo, pldb(idp)%plantnm,  "DRAINAGE_MGT ",       &
                   phubase(j), pcom(ihru)%plcur(j)%phuacc,  soil(ihru)%sw,                                  &
                   pl_mass(j)%tot(j)%m, rsd1(j)%tot_com%m, sol_sumno3(j),                                   &
                   sol_sumsolp(ihru),hru(j)%lumv%sdr_dep
            endif

          case ("skip")    !! skip a year
            yr_skip(j) = 1

      end select

      if (mgt%op /= "skip") hru(j)%cur_op = hru(j)%cur_op + 1  !don't icrement if skip year
      if (hru(j)%cur_op > sched(isched)%num_ops) then
        hru(j)%cur_op = 1
      end if

      mgt = sched(isched)%mgt_ops(hru(j)%cur_op)

      return

      end subroutine mgt_sched


c iritest.for, version number can be found at the end of this comment.
c-----------------------------------------------------------------------
c
c test program for the iri_web subroutine
c
c corrections
c-version-mm/dd/yy------------------------------------------------------
c 2000.01 05/07/01 initial version
c 2000.02 07/11/01 line 210: do i=1,100 instead of i=2,100 (K. Tokar)
c 2000.03 28/12/01 output oar(39) for IG12 (R. Conkright, NGDC, NOAA)
c 2000.04 28/10/02 replace TAB/6 blanks, enforce 72/line (D. Simpson)
c 2000.05 02/06/03 Ne(Te) only 300,400; foF1 and hmF1 output corr.
c 2000.06 01/19/05 (.not.jf(20)) instead of (..jf(2)) (G. Schiralli)
c 2005.01 05/06/06 included spread-F (jf(28)) and topside (jf(29)) options
c 2007.00 05/18/07 Release of IRI-2007
c
      INTEGER           pad1,pad2,pad3
      DIMENSION         outf(20,100),oar(50,100),jfi(6)
      LOGICAL		    jf(30)
      CHARACTER*2       timev(2)
      CHARACTER*3       uni(48),sopt
      CHARACTER*4       IMZ(8),MAP,xtex,coorv(2)
      CHARACTER*5       ITEXT(8)
      CHARACTER*6       pna(48)
      CHARACTER*8       bopt
      CHARACTER*9       topt,pname(6)
      CHARACTER*10      iopt
      CHARACTER*16      f1opt

      DATA  IMZ  /' km ','GEOD','GEOD','yyyy',' mm ',' dd ','YEAR',
     &      'L.T.'/, ITEXT/'  H  ',' LATI',
     &      ' LONG',' YEAR','MONTH',' DAY ','DAYOF',' HOUR'/

      data pna/'NmF2','hmF2','NmF1','hmF1','NmE','hmE','NmD','hmD',
     &  'h05','B0','NVmin','hVtop','Tpeak','hTpek','T300','T400','T600',
     &  'T1400','T3000','T120','Ti450','hTeTi','sza','sndec','dip',
     &  'dipla','modip','dela','Srise','Sset','seasn','nseas','Rz12',
     &  'cov','B1','M3000','TEC','TECtp','IG12','F1prb','F107d',
     &  'C1','daynr','vdrft','foF2r','F1noL','F1+L','sp_F'/
      data uni/'m-3','km','m-3','km','m-3','km','m-3','km','km','km',
     &   'm-3','km','K','km',7*'K','km',5*'deg',' ',2*'h',6*' ','m-2',
     &   '%',5*' ','m/s',4*' '/,timev/'LT','UT'/,coorv/'geog','geom'/

        data jfi/8,9,13,14,15,16/

c user input of IRI input parameters
c
1       print *,'jmag(=0/1,geog/geom),lati/deg,long/deg'
        read(5,*) jm,xlat,xlon
        print *,'year(yyyy),mmdd(or -ddd),iut(=0/1,LT/UT),hour'
        read(5,*) iy,imd,iut,hour
        print *,'height/km'
        print *,'(enter  0 for list of peak heights and densities)'
        print *,'(enter -1 for plasma frequencies, B0, M3000, ',
     &                        'valley, width and depth,)'
        print *,'(         F1 probability, equatorial vertical ',
     &         'ion drift, and)'
        print *,'(         foF2 storm/quiet ratio,)'
        print *,'(         or 3 parameter of your choice)'
        read(5,*) hx
        print *,'upper height [km] for TEC integration (0 for no TEC)'
        read(5,*) htec_max

        print *,'variable? (1/2/../8 for height/lat/long/year/month/',
     &                        'day/day of year/hour)'
        read(5,*) ivar
        print *,'begin, end, and stepsize for the selected variable'
        read(5,*) vbeg,vend,vstp

        print *,'Options: t(rue) or f(alse)'
        print *,'Standard: t,t,t,t,f,f,t,t,t,t,t,t,t,t,t,t,t,t,t,t,',
     &                        'f,t,f,t,t,t,t,f,f,f'
        print *,'Enter 0 to use standard or 1 to enter your own'
        read(5,*) jchoice
          do i=1,30
                jf(i)=.true.
                enddo
        if(jchoice.eq.0) then
c          jf(2)=.false.				  ! no temperatures
c          jf(3)=.false.				  ! no ion composition
          jf(5)=.false.               ! URSI foF2 model
          jf(6)=.false.               ! Newest ion composition model
          jf(21)=.false.			  ! no ion drift
          jf(23)=.false.              ! TTS Te model is standard
          jf(28)=.false.			  ! no spread-F
          jf(29)=.false.              ! New Topside options
          jf(30)=.false.              ! NeQuick topside
        else
          print *,'Compute Ne, T, Ni? (enter: t,t,t  if you want all)'
          read(5,*) jf(1),jf(2),jf(3)
        if(jf(1)) then
              print *,'LAY version: t=standard ver., f=LAY version. {t}'
              read(5,*) jf(11)
              print *,'Ne Topside: t=IRI-2001, f=new options {t}'
              read(5,*) jf(29)
              print *,'Ne Topside: t=IRI01_corrt, f=NeQuick {t}'
              read(5,*) jf(30)
              print *,'Ne Topside: t=F10.7<188, f=unlimited {t}'
              read(5,*) jf(7)
              print *,'foF2 model: t=CCIR, f=URSI-88 {standard:f}'
              read(5,*) jf(5)
              print *,'foF2: t=with storm model, f=without {t}'
              read(5,*) jf(26)
              print *,'F2 peak density or foF2: t=model, ',
     &              'f=user input {t}'
              read(5,*) jf(8)
              print *,'F2 peak height or M3000F2: t=model, ',
     &              'f=user input {t}'
              read(5,*) jf(9)
              print *,'Bottomside thickness B0: t=Table-option, ',
     &            'f=Gulyaeva {t}.'
              read(5,*) jf(4)
              print *,'F1 peak density or foF1: t=model, ',
     &            'f=user input {t}'
              read(5,*) jf(13)
            if(.not.jf(11)) then
              print *,'F1 peak height: t=model, f=user input {t}'
              read(5,*) jf(14)
            endif
              print *,'F1: t=with probability model, f=without   {t}'
              read(5,*) jf(19)
              print *,'F1: t=standard probability, f=with L ',
     &            'condition {t}'
              read(5,*) jf(20)
              print *,'E peak density or foE: t=model, f=user input {t}'
              read(5,*) jf(15)
              print *,'E peak height: t=model, f=user input {t}'
              read(5,*) jf(16)
              print *,'D: t=old model, f=new options {t}'
              read(5,*) jf(24)
          endif
        if(jf(2)) then
              print *,'Te(Ne) model: t=not used, f=correlation is',
     &          ' used. {t}'
              read(5,*) jf(10)
              print *,'Te: t=AEROS/ISIS model, f=InterKosmos model {f}'
              read(5,*) jf(23)
          endif
        if(jf(3)) then
              print *,'Ion comp. model: t=DS78/DY85, f=DS95/TTS05 {f}'
              read(5,*) jf(6)
              print *,'Ni: t=ion composition in %, f=ion densities',
     &             'in cm-3 {t}'
              read(5,*) jf(22)
              endif
            print *,'Equat. Vert. Ion Drift: t=computed, ',
     &            'f=not computed {t}'
            read(5,*) jf(21)
            print *,'Spread-F probability: t=computed, ',
     &            'f=not computed {t}'
            read(5,*) jf(28)
            print *,'Sunspot index: t=from file, f=user input.  {t}'
            read(5,*) jf(17)
            print *,'Ionospheric index: t=from file, f=user input. {t}'
            read(5,*) jf(27)
            print *,'F10.7D Index: t=from file, f=user input {t}'
            read(5,*) jf(25)
            print *,'UT/LT computation: t=no date change, f=ut_lt ',
     &             'subroutine {t}'
            read(5,*) jf(18)
            print *,'Message output unit: t=(UNIT=6), f=(UNIT=12). {t}'
            read(5,*) jf(12)
       endif

c option to enter three additional parameters
c
      if(hx.lt.0) then
        print *,'Three additional output parameters (number:1-48)'
        print *,(pna(j),j=1,10)
        print *,(pna(j),j=11,20)
        print *,(pna(j),j=21,30)
        print *,(pna(j),j=31,40)
        print *,(pna(j),j=41,48)
        print *,'or 0,0,0 for default (F1 probability[40], equ. vert. ',
     &   'ion drift[44], foF2_st/_quiet[45])'
        read(5,*) pad1,pad2,pad3
        if(pad1.eq.0) pad1=40     ! F1 probability
        if(pad2.eq.0) then
             pad2=44              ! equatorial vertical ion drift
             jf(21)=.true.
             endif
        if(pad3.eq.0) pad3=45     ! fof2_storm/foF2_quiet
      endif

c option to enter measured values for NmF2, hmF2, NmF1, hmF1, NmE, hmE,
c N(300), N(400), N(600) if available;
c
          print *,' '
          print *,' '
          print *,' '
          numstp=int((vend-vbeg)/vstp)+1
              if(ivar.eq.1) numstp=1
        if(jf(1)) then
         if(.not.jf(8).or..not.jf(9).or..not.jf(13).or..not.jf(14).or.
     &      .not.jf(15).or..not.jf(16)) then
          var=vbeg
          i=1
2234              if(.not.jf(8)) then
                jf(26)=.false.    ! storm model off, if user input
                        print *,'foF2/Mhz or NmF2/m-3 for ',itext(ivar),
     &                      '=',var
                        read(5,*) oar(1,i)
                    pname(1)='foF2/MHz'
                    if(oar(1,i).gt.30.) pname(1)='NmF2/m-3'
                        endif
              if(.not.jf(9)) then
                        print *,'hmF2/km or M3000F2 for ',itext(ivar),
     &                      '=',var
                        read(5,*) oar(2,i)
                    pname(2)='M(3000)F2'
                    if(oar(2,i).gt.50.) pname(2)='hmF2/km'
                        endif
              if(.not.jf(13)) then
                        print *,'foF1/MHz or NmF1/m-3 for ',itext(ivar),
     &                  '=',var
                        read(5,*) oar(3,i)
                    pname(3)='foF1/MHz'
                    if(oar(3,i).gt.30.) pname(3)='NmF1/m-3'
                        endif
              if(.not.jf(14)) then
                        print *,'hmF1/km for ',itext(ivar),'=',var
                        read(5,*) oar(4,i)
                    pname(4)='hmF1/km'
                        endif
              if(.not.jf(15)) then
                        print *,'foE/MHz or NmE/m-3 for ',itext(ivar),
     &                     '=',var
                        read(5,*) oar(5,i)
                    pname(5)='foE/MHz'
                    if(oar(5,i).gt.30.) pname(5)='NmE/m-3'
                        endif
              if(.not.jf(16)) then
                        print *,'hmE/km for ',itext(ivar),'=',var
                        read(5,*) oar(6,i)
                    pname(6)='hmE/km'
                        endif
           i=i+1
           var=var+vstp
           if(ivar.gt.1.and.var.le.vend) goto 2234
        endif
        endif

c option to enter Ne for Te-Ne relationship
c
        if(jf(2).and..not.jf(10)) then
          var=vbeg
          do 1235 i=1,numstp
                        print *,'Ne(300km),Ne(400km)/m-3',
     &                     ' for ',itext(ivar),'=',var,' [-1 if not]'
                        read(5,*) oar(15,i),oar(16,i)
1235            var=var+vstp
          endif

c option to enter F107D
c
            if(.not.jf(25)) then
                        print *,'User input for F107D:'
                        read(5,*) f107d
                        do i=1,100
                                    oar(41,i)=f107d
                                    enddo
                        endif

c option to enter Rz12 and/or IG12
c
            if(.not.jf(17)) then
                        print *,'User input for Rz12'
                        read(5,*) oar(33,1)
                        do i=2,100
                                    oar(33,i)=oar(33,1)
                                    enddo
                        endif

            if(.not.jf(27)) then
                        print *,'User input for IG12'
                        read(5,*) oar(39,1)
                        do i=2,100
                                    oar(39,i)=oar(39,1)
                                    enddo
                        endif

c end of user input
c

        num1=(vend-vbeg)/vstp+1
        numstp=iabs(num1)
        if(numstp.GT.100) numstp=100

        map='URSI'
        if(jf(5)) map='CCIR'

        bopt='Gulyaeva'
        if(jf(4)) bopt='B0-Table'

        iopt='DS95&TTS04'
        if(jf(6)) iopt='DS78&DY85 '

        sopt='off'
        if(jf(26)) sopt='on '

        topt='TTSA-2000'
        if(jf(23)) topt='IRI-95'

        if(jf(19)) then
              f1opt='Scotto-97 no L'
              if(.not.jf(20)) f1opt='Scotto-97 with L'
        else
              f1opt='IRI-95'
        endif

        hxx=hx
        jmag=jm
        mmdd=imd

c calling IRI subroutine
c

        call iri_web(jmag,jf,xlat,xlon,iy,mmdd,iut,hour,
     &          hxx,htec_max,ivar,vbeg,vend,vstp,outf,oar)

c preparation of results page
c

        write(7,3991) iy,mmdd,hour,timev(iut+1),coorv(jmag+1),xlat,xlon
        if(jf(1)) then
       		if(jf(29)) then
        		if(jf(30)) then
                	write(7,3314)
        		else
                	write(7,3315)
                endif
            else
        		if(jf(30)) then
                	write(7,3316)
        		else
                	write(7,3317)
                endif
            endif
                if(jf(8)) write(7,301) map
                if(jf(9)) write(7,303)
                if(.not.jf(24)) write(7,3081)
                write(7,309) bopt
                write(7,3291) sopt
                write(7,3295) f1opt
                numi=numstp
                if(ivar.eq.1) numi=1
                do j=1,6
                  ij=jfi(j)
                  if(.not.jf(ij)) then
                     write(7,302) pname(j)
                     write(7,402) (oar(j,i),i=1,numi)
                     endif
                  enddo
                endif

        if(jf(2)) write(7,3292) topt
        if(jf(3)) write(7,329) iopt

        if(ivar.eq.1) then
                if(oar(3,1).lt.1.) oar(4,1)=0.
                yp2=0
                if(oar(3,1).gt.0.0) yp2=oar(3,1)/1.e6
                write(7,213) oar(1,1)/1.E6,yp2,oar(5,1)/1.E6
                write(7,214) oar(2,1),oar(4,1),oar(6,1)
        else
                write(7,307)
        endif

        write(7,211) oar(23,1),oar(25,1),oar(27,1)

        if(.not.jf(17)) then
                write(7,223) oar(33,1)
        else
                write(7,212) oar(33,1)
        endif

        if(.not.jf(27)) then
                write(7,2231) oar(39,1)
        else
                write(7,2121) oar(39,1)
        endif

        if(htec_max.gt.50.0) write(7,3914) htec_max
        if(pad1.eq.44.or.pad2.eq.44.or.pad3.eq.44) write(7,3915)
        if(pad1.eq.40.or.pad2.eq.40.or.pad3.eq.40) write(7,4915)
        if(pad1.eq.45.or.pad2.eq.45.or.pad3.eq.45) write(7,4916)
        if(pad1.eq.48.or.pad2.eq.48.or.pad3.eq.48) write(7,4196)

3991    format(///'DATE(yyyy/-ddd or mmdd/hh.h):',I4,'/',I4,'/',F4.1,
     &      A2,2X,A4,' Lat/Long=',F5.1,'/',F6.1/)
3914    format(/'TEC [1.E16 m-2] is obtained by numerical integration',
     &     ' in 1km steps'/'  from 50 to ',f6.1,' km.  t is the',
     &     ' percentage of TEC above the F peak.')
3915    format(/'vdrft: equatorial vertical F-region drift.')
4915    format(/'F1_pb: F1-layer occurrence probability')
4916    format(/'foF2r: foF2_storm/foF2_quiet')
4196    format(/'sp_F: spread-F occurrence probability')
3916    format(/'M3000F2: Propagation factor related to hmF2'/
     &     'B0: bottomside thickness parameter.')
301     format(A4,' maps are used for the F2 peak density (NmF2)')
302     format(A9,' provided by user:')
402     format(7(1PE10.3))
303     format('CCIR maps are used for the F2 peak height (hmF2)')
304     format(A25,'=',F5.1,') provided by user')
307     format(1x/'Solar and magnetic parameter for the 1st profile',
     &          ' point:')
309     format(A8,' option is used for the bottomside thickness ',
     &          'parameter B0')
3081    format('Special D-region output with all options')
329     format(A10,' option is used for ion composition')
3291    format('The foF2 STORM model is turned ',A3)
3292    format(A9,' option is used for the electron temperature')
3293    format(A8,' option is used for the D-region Ne')
3295    format(A16,' option is used for the F1 occurrence probability')
211     format('Solar Zenith Angle/degree',28X,F6.1/
     &          'Dip (Magnetic Inclination)/degree',20X,
     &          F6.2/'Modip (Modified Dip)/degree',26X,F6.2)
212     format('Solar Sunspot Number (12-months running mean) Rz12',
     &          4X,F5.1)
223     format('Solar Sunspot Number (12-months running mean) Rz12',
     &          4X,F5.1,'{user provided input}')
2121    format('Ionospheric-Effective Solar Index IG12',16X,F5.1)
2231    format('Ionospheric-Effective Solar Index IG12',16X,
     &          F5.1,'{user provided input}')
213     format(/'Peak Densities/cm-3: NmF2=',F9.1,'   NmF1=',F9.1,
     &          '   NmE=',F9.1)
214     format('Peak Heights/km:     hmF2=',F9.2,'   hmF1=',F9.2,
     &          '   hmE=',F9.2/)
3314    format('IRI-2001 is used for topside Ne profile')
3315    format('TTS model is used for topside Ne profile')
3316    format('Corrected IRI01 is used for topside Ne profile')
3317    format('NeQuick is used for topside Ne profile')
c
c table head .......................................................
c

        agnr=7          !output unit number
        xtex=imz(ivar)
        if(jmag.gt.0.and.(ivar.eq.2.or.ivar.eq.3)) xtex='GEOM'
        if(iut.gt.0.and.ivar.eq.8) xtex='U.T.'

        PIKTAB=0
        IF(IVAR.NE.1) THEN
                IF(HX.LT.1.0) PIKTAB=1
                IF(HX.LT.0.0) PIKTAB=2
                ENDIF
        if(.not.jf(24)) piktab=3

        IF(PIKTAB.EQ.3) WRITE(7,8199) ITEXT(IVAR),xtex
        IF(PIKTAB.EQ.2) WRITE(7,8194) ITEXT(IVAR),pna(pad1),
     &    pna(pad2),pna(pad3),xtex,uni(pad1),uni(pad2),uni(pad3)
        IF(PIKTAB.EQ.1) WRITE(7,8192) ITEXT(IVAR),xtex
        IF(PIKTAB.EQ.0) WRITE(7,8193) ITEXT(IVAR),xtex

8192  FORMAT(/'-'/2X,A5,6X,'PEAK ALTITUDES IN KM',8X,'PEAK DEN',
     &  'SITIES IN cm-3  TEC top/%'/3X,A4,'    hmF2  hmF1   hmE   ',
     &  'hmD      NmF2   NmF1    NmE    NmD  1E16m-2')
8194  FORMAT(/'-'/2X,A5,15X,'E-VALLEY',3X,'PLAS FREQ/',
     & ' MHz  ',A6,3X,A6,3X,A6/3X,A4,' M3000 B0/km  W/km Depth ',
     &  ' foF2 foF1  foE   ',A3,6X,A3,6X,A3)
8193  FORMAT(/'-'/1X,A5,' ELECTRON DENSITY   TEMPERATURES ',
     &  8X,'ION PERCENTAGES/%',5x,'1E16m-2'/2X,A4,' Ne/cm-3 Ne/NmF2',
     &  ' Tn/K  Ti/K  Te/K  O+  N+  H+ He+ O2+ NO+ Clust TEC t/%')
8199  FORMAT(/'-'/1X,A5,12X,' D-REGION ELECTRON DENSITY IN CM-3'/
     &  2X,A4,7x,'Mechtley',3x,'Friedrich',7X,'Danilov et al. 1995'/
     &  13x,'-Bilitza',4X,'-Torkar',5x,'standard',2x,'major SW',2x,
     &  'strong WA')

        xcor=vbeg

        do 1234 li=1,numstp

c
c special output: peak densities and altitudes
c

      IF(PIKTAB.eq.1) THEN
        if(oar(3,li).lt.1.) oar(4,li)=0.
        iyp1=int(oar(1,li)/1.e6+.5)
        iyp2=0
        if(oar(3,li).gt.0.0) iyp2=int(oar(3,li)/1.e6+.5)
        iyp3=int(oar(5,li)/1.e6+.5)
        iyp4=int(oar(7,li)/1.e6+.5)
            tec=oar(37,li)
        if(tec.gt.0.0) then
            tec=tec/1.e16
            itopp=int(oar(38,li)+.5)
        else
            tec=-1.0
            itopp=-1
        endif
        WRITE(7,3910) XCOR,oar(2,li),oar(4,li),oar(6,li),oar(8,li),
     &    iyp1,iyp2,iyp3,iyp4,tec,itopp
3910    FORMAT(F7.1,2X,4F6.1,1X,I9,3I7,1x,f6.2,i4)
        GOTO 1234
      ENDIF

      IF(PIKTAB.eq.2) THEN
        yp1=sqrt(oar(1,li)/1.24e10)
        yp2=0.0
        if(oar(3,li).gt.0.0) yp2=sqrt(oar(3,li)/1.24e10)
        yp3=sqrt(oar(5,li)/1.24e10)
c        if(pad1.eq.45.and.oar(pad1,li).le.0.0) oar(pad1,li)=-1.
c        if(pad2.eq.45.and.oar(pad2,li).le.0.0) oar(pad2,li)=-1.
c        if(pad3.eq.45.and.oar(pad3,li).le.0.0) oar(pad3,li)=-1.
        WRITE(7,3919) XCOR,oar(36,li),oar(10,li),oar(12,li)-oar(6,li),
     &    oar(11,li)/oar(5,li),yp1,yp2,yp3,oar(pad1,li),oar(pad2,li),
     &    oar(pad3,li)
3919    FORMAT(F7.1,2X,f4.2,1x,f5.1,1x,f5.1,1x,f5.3,F6.2,2F5.2,
     &    1PE9.2,1PE9.2,1PE9.2)
        GOTO 1234
      ENDIF

c special output for D-region options
c
      IF(PIKTAB.eq.3) THEN
        hxx=hx
        if(ivar.ne.1.and.hx.lt.20.) hxx=85.
        ip1=int(outf(1,li)/1.e6+.5)
        ip2=int(outf(13,li)/1.e6+.5)
        if(ivar.eq.1) hxx=xcor
        ihx=int((hxx-60)/5.)+1
        ixne=-1
        ixn1=-1
        ixn2=-1
        if(ihx.gt.0.and.ihx.lt.7) then
              hihx=60+(ihx-1)*5
              ixne=int((outf(14,ihx)+(outf(14,ihx+1)-outf(14,ihx))/
     &                   5*(hxx-hihx))/1.e6+.5)
              ih1=ihx+7
              ixn1=int((outf(14,ih1)+(outf(14,ih1+1)-outf(14,ih1))/
     &                   5*(hxx-hihx))/1.e6+.5)
              ih2=ihx+14
              ixn2=int((outf(14,ih2)+(outf(14,ih2+1)-outf(14,ih2))/
     &                   5*(hxx-hihx))/1.e6+.5)
              endif
        WRITE(7,3819) XCOR,ip1,ip2,ixne,ixn1,ixn2
3819    FORMAT(F7.1,2X,2i10,5X,3I10)
        GOTO 1234
      ENDIF
c
c normal output
c
        if(ivar.eq.1) then
                oar(1,li)=oar(1,1)
                oar(37,li)=oar(37,1)
                oar(38,li)=oar(38,1)
                endif
        jne=int(outf(1,li)/1.e6+.5)
        xner=outf(1,li)/oar(1,li)
        jtn=int(outf(2,li)+.5)
        jti=int(outf(3,li)+.5)
        jte=int(outf(4,li)+.5)
        jio=INT(OUTF(5,li)+.5)
        jih=INT(OUTF(6,li)+.5)
        jihe=INT(OUTF(7,li)+.5)
        jino=INT(OUTF(8,li)+.5)
        jio2=INT(OUTF(9,li)+.5)
        jicl=INT(OUTF(10,li)+.5)
        jin=INT(OUTF(11,li)+.5)
        if(outf(1,li).lt.0) jne=-1
        if(outf(1,li).lt.0) xner=-1.
        if(outf(2,li).lt.0) jtn=-1
        if(outf(3,li).lt.0) jti=-1
        if(outf(4,li).lt.0) jte=-1
        if(outf(5,li).lt.0) jio=-1
        if(outf(6,li).lt.0) jih=-1
        if(outf(7,li).lt.0) jihe=-1
        if(outf(8,li).lt.0) jino=-1
        if(outf(9,li).lt.0) jio2=-1
        if(outf(10,li).lt.0) jicl=-1
        if(outf(11,li).lt.0) jin=-1
        if(tec.gt.0.0) then
            tec=oar(37,li)/1.e16
            itopp=int(oar(38,li)+.5)
        else
            tec=-1.0
            itopp=-1
        endif
        WRITE(7,7117) XCOR,jne,xner,jtn,jti,jte,jio,jin,
     &        jih,jihe,jino,jio2,jicl,tec,itopp
7117    FORMAT(F6.1,I8,1x,F6.3,3I6,7I4,f6.1,i4)

1234    xcor=xcor+vstp

        print *,'Enter 0 to exit or 1 to generate another profile?'
        read(5,*) icontinue
        if (icontinue.gt.0) goto 1

            stop
            end


c
c     ****************************************************************
c     *                                                              *
c     *                        module mod_mpc                        *
c     *                                                              *
c     *                       written by : gvt                       *
c     *                                                              *
c     *                    last modified : 09/3/2017 rhd             *
c     *                                                              *
c     *  Module for the multipoint constraint (MPC) and tied contact *
c     *  data structures; use a module to permit use of global       *
c     *  values in the MPC calculations.                             *
c     *                                                              *
c     ****************************************************************
c
c
      module mod_mpc
c
c           Declare Modules
c
      include 'param_def'
c
c           Declare Variables
c
c
c           Variables for the multipoint constraint equations
c
c           num_user_mpc = number of multipoint constraint (MPC)
c               equations specified by the user; stored in the
c               user_mpc_table() array
c           num_tied_con_mpc = number of MPC equations generated
c               by the tied contact processor; stored in the
c               tied_con_mpc_table() array
c
c           Components of the "mpc_eqn" data type:
c
c           num_terms = number of terms in the MPC equation
c           constant = right hand side constant value for the MPC
c               equation; in general the constant can be zero or
c               non-zero, but expecting a constant equal to zero for
c               tied contact
c           node_list = integer pointer component array to store the
c               node ID numbers in the MPC equation; set the dimension
c               of node_list to num_terms
c           dof_list = integer pointer component array to store the
c               node DOF numbers in the MPC equation (1=u, 2=v, 3=w);
c               set the dimension of node_list to num_terms
c           multiplier_list = real pointer component array to store
c               the coefficient multiplier for each node DOF in the
c               MPC equation; set the dimension of node_list to
c               num_terms
c
c           Arrays declared with the "mpc_eqn" data type:
c
c           user_mpc_table = store the MPC equations specified by the
c               user; the MPC equation values are stored in the data
c               type components
c           tied_con_mpc_table = the MPC equations generated and stored
c               by the tied contact processing routine; expect the right
c               hand side constant to be zero for the tied contact MPC
c               equations; the tied contact MPC equation values are
c               stored in the data type components
c
c           Note that the max_mpc array size for user_mpc_table
c           and max_mpc_tied for tied_con_mpc_table are set in
c           mem_allocaste.f
c
      integer  num_user_mpc, num_tied_con_mpc, nmpc
c
      logical  mpcs_exist
c
      type :: mpc_eqn
        integer num_terms
        real constant
        integer, pointer,  dimension (:) :: node_list
        integer, pointer, dimension (:) :: dof_list
        real, pointer, dimension (:) :: multiplier_list
      end type
c
      type (mpc_eqn), allocatable,
     &            dimension (:) :: user_mpc_table
      type (mpc_eqn), allocatable,
     &            dimension (:) :: tied_con_mpc_table
c
c
c           Variables for the tied contact data
c
c           num_surfaces = number of mesh surfaces defined in the input
c               data file; these are all of the master and slave mesh
c               surfaces used in the tied contact sets
c           num_tied_sets = number of tied contact pair sets defined in
c               the input data file; each tied contact set can use one
c               or more pairs of surfaces
c
c           Components of the "surface" data type:
c
c           id = character label for the mesh surface name
c           num_elems = number of elements in the list to define the
c               surface; use to set the size of elem_list and face_list
c           elem_list = integer pointer component array to store the
c               element ID numbers that define the surface
c           face_list = integer pointer component array to store the
c               element face numbers that define the surface
c
c           Components of the "tied_set" data type:
c
c           id = character label for the tied contact set name
c           tolerance = gap tolerance distance between the master and
c               slave surface for slave nodes to be in contact with the
c               master surface
c           adjust_gap = logical flag, if true then adjust the slave
c               node initial position to be located on the master
c               surface
c           num_pairs = number of surface pairs in the tied contact set;
c               a tied contact set is defined with one or more pairs
c               of surfaces (a master and slave surface)
c           master_list = integer pointer component array to store the
c               the master surface ID numbers in the tied contact set;
c               use this integer surface ID number to access the
c               data in the surface_table() array
c           slave_list = integer pointer component array to store the
c               the slave surface ID numbers in the tied contact set;
c               use this integer surface ID number to access the
c               data in the surface_table() array
c
c           Array declared with the "surface" data type:
c
c           surface_table = store the data for all the mesh surfaces
c               defined by the user; the element list for each surface
c               is stored in the data type components
c
c           Array declared with the "tied_set" data type:
c
c           tied_contact_table = store the data for all the tied contact
c               sets defined by the user; the surface lists and data are
c               stored in the data type components
c
c           Note that the max_surfaces and max_tied_sets array sizes
c           are set in param_def
c
c
      integer  num_surfaces, num_tied_sets
c
      logical  tied_sets_exist, tied_con_mpcs_constructed,
     &         display_mpcs
c
      type :: surface
        character(len=16) :: id
        integer num_elems
        integer, pointer, dimension (:) :: elem_list
        integer, pointer, dimension (:) :: face_list
      end type
c
      type :: tied_set
        character(len=16) :: id
        real tolerance
        logical adjust_gap
        integer num_pairs
        integer, pointer, dimension (:) :: master_list
        integer, pointer, dimension (:) :: slave_list
      end type
c
c
      type (surface), allocatable, dimension (:) :: surface_table
      type (tied_set), allocatable, dimension (:) :: tied_contact_table
c
c
c           Components of the "nonzero_locs" data type:
c
c           length = the current length of the integer vector component
c           loc_list = integer vector containing the list of non-zero
c               indices in the equation (similar to k_indexes)
c
c           Arrays declared with the "nonzero_locs" data type:
c
c           eqn_row = used by the MPC solver routines to temporarily store
c               the row portions of all equations in the stiffness matrix
c               while adding terms (later converted k_indexes)
c               It is also used to store the entire dep eqns (row & col).
c               This structure is deallocated after the first MPC solve.
c
      type :: nonzero_locs
        integer length
        integer, pointer, dimension (:) :: loc_list
      end type
c
      type (nonzero_locs), allocatable, dimension(:) :: eqn_row
c
c
c           Variables for MPC solver routines
c
c           dep_check = integer vector used to tell if a given equation
c               number is a dependent term in an MPC equation and which
c               MPC equation it is in, e.g. if dof 13 is a dep term in
c               in MPC #5, dep_check(13) = 5, else = 0
c           dep_dof = lists the dep term of each MPC eqn, e.g. if MPC eqn
c               #5 has dep term 13, dep_dof(5) = 13
c           ind_dof = lists all the independent terms of each MPC eqn
c           num_terms = contains the number of ind terms in each MPC eqn,
c               e.g. if MPC eqn #5 has 6 terms, num_terms(5) = 5 (because
c               the first term is the dep).  This vector is used to reference
c               the correct positions in 'ind_dof' and 'multi_list' for
c               each MPC eqn
c           multi_list = containst the multiplier corresponding to each ind
c               term in each MPC, therefore has same length as ind_dof
c
c           The 'dep_dof', 'ind_dof', 'num_terms', and 'multi_list', data
c               structures are used to prevent excessive access to the f90
c               data structures used to contain the MPC equations.  They are
c               quick to create, but can obviously take a lot of memory, so
c               they are created and then deallocated for each MPC solve.
c
      integer  dep_trms_len
c
      integer, allocatable,
     &        dimension (:) :: dep_check, dep_dof,
     &                         ind_dof, num_terms,
     &                         dep_ptr, num_dep_trms,
     &                         dep_trms, abs_dep_ptr
c
      real, allocatable, dimension (:) :: multi_list
c
      double precision,
     &            allocatable,
     &            dimension (:) :: dep_coef, dep_rhs
c
c
      end module mod_mpc


      subroutine synpop
c******************************************************************************
c     Synthetic spectrum routine for stellar populations; usually meant for
c     integrated light spectra.
c******************************************************************************

      implicit real*8 (a-h,o-z)
      include 'Atmos.com'
      include 'Quants.com'
      include 'Linex.com'
      include 'Factor.com'
      include 'Mol.com'
      include 'Pstuff.com'
      include 'Multimod.com'
      real*8 tempspec(5,10000), rspec(10000)
      character*80 holdline(5,30)
      character*80 line

c*****read the parameter file
      call params

c*****open the model table input file and the summary table output file;
c     read the information from the table input file
      call tablepop (2)

c*****open the standard output file
60    nf1out = 20
      lscreen = 8
      array = 'STANDARD OUTPUT'
      nchars = 15
      call infile ('output ',nf1out,'formatted  ',0,nchars,
     .             f1out,lscreen)

c*****FIRST PASS:  For each model, compute a raw synthetic spectrum;
c*****the starting do/if loops are for isotopic things only
      xhyd = 10.0**xsolar(1)
      do mmod=1,modtot
         if (numiso .gt. 0) then
            if (nisos .gt. 0) then
               do k=1,numiso
                  do l=1,nisos
                     if (isotope(k) .eq. isospecial(l)) then
                        do m=1,numisosyn
                           isoabund(k,m) = fracspecial(mmod,l)
                        enddo
                     endif
                  enddo
               enddo
            endif
         endif

c*****read in the model atmospheres and their summary output files
         line = synpre
         num = 80
         call getcount (num,line)
         if (mmod .lt. 10) then
            write (line(num+1:num+1),1013) mmod
         else
            write (line(num+1:num+2),1014) mmod
         endif
         nf2out = 21
         fmodoutput(mmod) = line
         f2out = fmodoutput(mmod)
         lscreen = 12
         array = 'INDIVIDUAL MODEL RAW SYNTHESIS OUTPUT'
         nchars = 37
         call infile ('output ',nf2out,'formatted  ',0,nchars,
     .                f2out,lscreen)
         line = modpre
         num = 80
         call getcount (num,line)
         if (mmod .lt. 10) then
            write (line(num+1:num+1),1013) mmod
         else
            write (line(num+1:num+2),1014) mmod
         endif
         nfmodel = 30
         fmodinput(mmod) = line
         fmodel = fmodinput(mmod)
         lscreen = 14
         array = 'INDIVIDUAL MODEL ATMOSPHERE'
         nchars = 27
         call infile ('input  ',nfmodel,'formatted  ',0,nchars,
     .                fmodel,lscreen)
         call inmodel
         write (nf2out,1001) moditle

c*****change the "default" abundances to be the ones read from the table file
         do i=1,nabs
            iabund = nint(elspecial(i))
            xabu(iabund) = 10.**abspecial(mmod,i)/xhyd
         enddo

c*****open the line list file and the strong line list file
         nflines = 31
         lscreen = 16
         array = 'THE LINE LIST'
         nchars = 13
         call infile ('input  ',nflines,'formatted  ',0,nchars,
     .                flines,lscreen)
         if (dostrong .gt. 0) then
            nfslines = 32
            lscreen = 18
            array = 'THE STRONG LINE LIST'
            nchars = 20
            call infile ('input  ',nfslines,'formatted  ',0,nchars,
     .                   fslines,lscreen)
         endif

c*****do the syntheses
         ncall = 1
         if (numpecatom .eq. 0 .or. numatomsyn .eq. 0) then
            isorun = 1
            nlines = 0
            mode = 3
            call inlines (1)
            call eqlib
            call nearly (1)
            call synspec
         else
            do n=1,numatomsyn
               isynth = n
               isorun = n
               start = oldstart
               sstop = oldstop
               mode = 3
               call inlines (1)
               call eqlib
               call nearly (1)
               call synspec
               linprintopt = 0
            enddo
         endif
         fluxmod(mmod,1) = flux
         call finish (0)
      enddo

c*****clear the mean spectrum array and the information array
      do i=1,5
         do j=1,10000
            tempspec(i,j) = 0.
         enddo
      enddo
      do i=1,5
         do j=1,30
            write (holdline(i,j),1008)
         enddo
      enddo

c*****open the file where the mean raw spectrum will be written
      nf9out = 23
      lscreen = 10
      array = 'MEAN RAW SYNTHESIS OUTPUT'
      nchars = 25
      call infile ('output ',nf9out,'formatted  ',0,nchars,
     .             f9out,lscreen)

c*****compute normalized weights
      weighttot = 0.
      do mmod=1,modtot
         weightmod(mmod,1) = fluxmod(mmod,1)*radius(mmod)**2*
     .                             relcount(mmod)
         weighttot = weighttot + weightmod(mmod,1)
      enddo
      do mmod=1,modtot
         weightmod(mmod,1) = weightmod(mmod,1)/weighttot
      enddo

c*****read back the syntheses, compute the weighted average
      do mmod=1,modtot
         newunit = 26
         open (newunit,file=fmodoutput(mmod))
         read (newunit,1001) line
         do j=1,numatomsyn
            lincount = 0
50          read (newunit,1001) line
            lincount = lincount + 1
            if (mmod .eq. 1) write (holdline(j,lincount),1001) line
            if (line(1:5) .eq. 'MODEL') then
               read (newunit,1001) line
               lincount = lincount + 1
               if (mmod .eq. 1) write (holdline(j,lincount),1001) line
               read (line,*) wavemod1, wavemod2, wavestep
               nw1 = nint(1000.*wavemod1)
               nw2 = nint(1000.*wavemod2)
               nws = nint(1000.*wavestep)
               nnn = (nw2-nw1)/nws + 1
               read (newunit,*) (rspec(n),n=1,nnn)
               do n=1,nnn
                  tempspec(j,n) = tempspec(j,n) + weightmod(mmod,1)*
     .                            rspec(n)
               enddo
            else
               go to 50
            endif
         enddo
         close (unit=newunit)
      enddo

c     write the average spectrum back to disk.
      line(1:7) = 'MODEL: '
      line(8:80) = popitle(1:73)
      do j=1,numatomsyn
         holdline(j,lincount-1) = line
         write (nf9out,1001) (holdline(j,l),l=1,lincount)
         write (nf9out,1003) (tempspec(j,n),n=1,nnn)
      enddo
      close (unit=nf9out)

c*****now plot the spectrum
      if (plotopt.eq.2 .and. specfileopt.gt.0) then
         nfobs = 33
         lscreen = 12
         array = 'THE OBSERVED SPECTRUM'
         nchars = 21
         if (specfileopt.eq.1 .or. specfileopt.eq.3) then
            call infile ('input  ',nfobs,'unformatted',2880,nchars,
     .                   fobs,lscreen)
         else
            call infile ('input  ',nfobs,'formatted  ',0,nchars,
     .                   fobs,lscreen)
         endif
      endif
      if (plotopt .ne. 0) then
         nf2out = nf9out
         f2out = f9out
         nf2out = 21
         lscreen = lscreen + 2
         array = 'RAW SYNTHESIS OUTPUT'
         nchars = 20
         call infile ('output ',nf2out,'formatted  ',0,nchars,
     .                f2out,lscreen)
         nf3out = 22
         lscreen = lscreen + 2
         array = 'SMOOTHED SYNTHESES OUTPUT'
         nchars = 25
         call infile ('output ',nf3out,'formatted  ',0,nchars,
     .                f3out,lscreen)
         if (f5out .ne. 'optional_output_file') then
            nf5out = 26
            lscreen = lscreen + 2
            array = 'POSTSCRIPT PLOT OUTPUT'
            nchars = 22
            call infile ('output ',nf5out,'formatted  ',0,nchars,
     .                   f5out,lscreen)
         endif
         if (plotopt .eq. 3) then
            call smooth (-1,ncall)
            choice = 'q'
         else
            call pltspec (lscreen,ncall)
         endif

c*****if needed, loop back with abundance changes
         if (choice .eq. 'n') then
            call chabund
            if (choice .eq. 'q') go to 60
         endif
      endif

c*****format statements
1001  format (a80)
1002  format ('POPULATION SYNTHESIS FOR INTEGRATED-LIGHT SPECTRA'/a80)
1003  format (10f7.4)
1004  format (a30, 2x, a10, 3f8.0)
1005  format ('#models =', i3, 5x, 'total weight =', f7.2//
     .        ('model#', i5, 5x, 'relative weight', f8.2))
1006  format (i3, 1x, f8.0, 2f8.2, 10f6.2)
1008  format (80(' '))
1009  format ('SPECIAL ELEMENTS OR NAMES OF ISOTOPES'/(10i8))
1010  format ('NO DECLARED SPECIAL ELEMENTS')
1011  format ('SPECIAL ISOTOPE NAMES'/((5f10.5)))
1012  format ('NO DECLARED SPECIAL ISOTOPES')
1013  format (i1)
1014  format (i2)
1015  format (6f13.5)

      end