!
! ODSSU_AtmAbsorption
!
! Module containing routines to compute the optical depth profile for SSUs
!
!
! CREATION HISTORY:
!       Based on CRTM_AtmAbsorption_ssu     by:  Quanhua Liu, JCSDA,      Dec  1, 2007
!       Rewritten for CRTMv2.0              by:  Yong Han, NOAA/NESDIS,   Oct  6, 2009
!       Revised                             by:  Paul van Delst, , JCSDA, Oct 26, 2009
!       Revised                             by:  Quanhua Liu, JCSDA,      Oct 29, 2009
!       Revised                             by:  Yong Chen, JCSDA,        Nov  9, 2009
!

MODULE ODSSU_AtmAbsorption

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds,               ONLY: fp
  USE Message_Handler,          ONLY: SUCCESS, FAILURE, WARNING, Display_Message
  USE Search_Utility,           ONLY: Bisection_Search
  USE CRTM_Parameters,          ONLY: ZERO, ONE
  USE CRTM_GeometryInfo_Define, ONLY: CRTM_GeometryInfo_type
  USE CRTM_AtmOptics_Define,    ONLY: CRTM_AtmOptics_type
  USE SSU_Input_Define,         ONLY: SSU_Input_type, &
                                      SSU_Input_GetValue, &
                                      SSU_Input_CellPressureIsSet
  USE ODSSU_TauCoeff,           ONLY: TC
  ! ...ODAS modules
  USE ODAS_Predictor_Define,    ONLY: ODAS_Predictor_type
  USE ODAS_AtmAbsorption,       ONLY: ODAS_AAVar_type => iVar_type , &
                                      ODAS_Compute_AtmAbsorption   , &
                                      ODAS_Compute_AtmAbsorption_TL, &
                                      ODAS_Compute_AtmAbsorption_AD
  ! ...ODPS modules
  USE ODPS_Predictor_Define,    ONLY: ODPS_Predictor_type
  USE ODPS_AtmAbsorption,       ONLY: ODPS_Compute_AtmAbsorption   , &
                                      ODPS_Compute_AtmAbsorption_TL, &
                                      ODPS_Compute_AtmAbsorption_AD
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Datatypes
  PUBLIC :: iVar_type
  ! Procedures
  PUBLIC :: ODSSU_Compute_Weights
  PUBLIC :: ODSSU_Compute_AtmAbsorption
  PUBLIC :: ODSSU_Compute_AtmAbsorption_TL
  PUBLIC :: ODSSU_Compute_AtmAbsorption_AD

  ! -------------------
  ! Procedure overloads
  ! -------------------
  INTERFACE ODSSU_Compute_AtmAbsorption
    MODULE PROCEDURE Compute_ODAS_AtmAbsorption
    MODULE PROCEDURE Compute_ODPS_AtmAbsorption
  END INTERFACE ODSSU_Compute_AtmAbsorption

  INTERFACE ODSSU_Compute_AtmAbsorption_TL
    MODULE PROCEDURE Compute_ODAS_AtmAbsorption_TL
    MODULE PROCEDURE Compute_ODPS_AtmAbsorption_TL
  END INTERFACE ODSSU_Compute_AtmAbsorption_TL

  INTERFACE ODSSU_Compute_AtmAbsorption_AD
    MODULE PROCEDURE Compute_ODAS_AtmAbsorption_AD
    MODULE PROCEDURE Compute_ODPS_AtmAbsorption_AD
  END INTERFACE ODSSU_Compute_AtmAbsorption_AD

  ! ----------
  ! Parameters
  ! ----------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  '$Id$'
  ! Message string length
  INTEGER, PARAMETER :: ML = 256

  ! ------------------------------------------
  ! Structure definition to hold forward model
  ! variables across FWD, TL, and AD calls
  ! ------------------------------------------
  TYPE :: iVar_type
    PRIVATE
    TYPE(ODAS_AAVar_type) :: ODAS(2)
    REAL(fp) :: Weight(2) = ZERO
    REAL(fp) :: CO2_Cell = ZERO
    INTEGER  :: Index_low = 1
  END TYPE iVar_type

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!------------------------------------------------------------------------------
!
! NAME:
!       ODSSU_Compute_Weights
!
! PURPOSE:
!       Subroutine to calculate ODSSU algorithm linear interpolation weighting
!       factors for the SSU CO2 cell pressure.
!
! CALLING SEQUENCE:
!       CALL ODSSU_Compute_Weights( SSU_Input   , &
!                                   SensorIndex , &
!                                   ChannelIndex, &
!                                   iVar          )
!
! INPUTS:
!       SSU_Input:       Structure containing the SSU input data.
!                        UNITS:      N/A
!                        TYPE:       SSU_Input_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       SensorIndex:     Sensor index id. This is a unique index associated
!                        with a (supported) sensor used to access the
!                        shared coefficient data for a particular sensor.
!                        See the ChannelIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       ChannelIndex:    Channel index id. This is a unique index associated
!                        with a (supported) sensor channel used to access the
!                        shared coefficient data for a particular sensor's
!                        channel.
!                        See the SensorIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       iVar:            Structure containing internal variables required for
!                        subsequent tangent-linear or adjoint model calls.
!                        The contents of this structure are NOT accessible
!                        outside of this module.
!                        UNITS:      N/A
!                        TYPE:       iVar_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
!
!:sdoc-:
!------------------------------------------------------------------------------

  SUBROUTINE ODSSU_Compute_Weights( &
    SSU_Input   , &  ! Input
    SensorIndex , &  ! Input
    ChannelIndex, &  ! Input
    iVar          )  ! Internal variable output
    ! Arguments
    TYPE(SSU_Input_type), INTENT(IN)     :: SSU_Input
    INTEGER             , INTENT(IN)     :: SensorIndex
    INTEGER             , INTENT(IN)     :: ChannelIndex
    TYPE(iVar_type)     , INTENT(IN OUT) :: iVar
    ! Parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'ODSSU_Compute_Weights'
    ! Variables
    CHARACTER(ML) :: msg
    REAL(fp) :: Time, Cell_Pressure

    ! Compute the CO2 cell pressure
    IF( SSU_Input_CellPressureIsSet(SSU_Input) ) THEN
      ! ...Interpolate the cell pressure data
      CALL SSU_Input_GetValue( SSU_Input, &
                               Channel = ChannelIndex, &
                               Cell_Pressure = Cell_Pressure )
      iVar%CO2_Cell  = Cell_Pressure
      iVar%Index_low = Bisection_Search( TC(SensorIndex)%TC_CellPressure(:,ChannelIndex), iVar%CO2_Cell )
    ELSE
      ! ...Get the mission time
      CALL SSU_Input_GetValue( SSU_Input, Time=Time )
      IF( Time < TC(SensorIndex)%Ref_Time(1) )THEN
        Time = TC(SensorIndex)%Ref_Time(1)
        WRITE( msg,'("Invalid time. Reset to ",f8.2)' ) Time
        CALL Display_Message( ROUTINE_NAME, TRIM(msg), WARNING )
      END IF
      ! ...Obtain CO2 cell pressure for given time
      CALL get_CO2_Cell_p( SensorIndex, ChannelIndex, Time, iVar%CO2_Cell )
      iVar%Index_low = Bisection_Search( TC(SensorIndex)%TC_CellPressure(:,ChannelIndex), iVar%CO2_Cell )
    END IF

    ! Compute the interpolation weights
    iVar%Weight(1) = (iVar%CO2_Cell - TC(SensorIndex)%TC_CellPressure(iVar%Index_low,ChannelIndex))/ &
                      (TC(SensorIndex)%TC_CellPressure(iVar%Index_low+1,ChannelIndex) - &
                       TC(SensorIndex)%TC_CellPressure(iVar%Index_low  ,ChannelIndex)   )
    iVar%Weight(2) = ONE - iVar%Weight(1)

  END SUBROUTINE ODSSU_Compute_Weights

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       ODSSU_Compute_AtmAbsorption
!
! PURPOSE:
!       Subroutine to calculate the layer optical depths due to gaseous
!       absorption for the SSU sensor for a given channel and atmospheric
!       profile.
!
! CALLING SEQUENCE:
!       CALL ODSSU_Compute_AtmAbsorption( SensorIndex , &
!                                         ChannelIndex, &
!                                         Predictor   , &
!                                         AtmOptics   , &
!                                         iVar          )
!
! INPUTS:
!       SensorIndex:     Sensor index id. This is a unique index associated
!                        with a (supported) sensor used to access the
!                        shared coefficient data for a particular sensor.
!                        See the ChannelIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       ChannelIndex:    Channel index id. This is a unique index associated
!                        with a (supported) sensor channel used to access the
!                        shared coefficient data for a particular sensor's
!                        channel.
!                        See the SensorIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! *********** INTENT NEEDS TO BE CORRECTED TO JUST (IN) ***********
! *********** PREDICTOR CAN BE MODIFIED IN ODPS_AtmAbsorption MODULE ************
!       Predictor:       Structure containing the integrated absorber and
!                        predictor profile data.
!                        UNITS:      N/A
!                        TYPE:       ODAS_Predictor_type
!                                      or
!                                    ODPS_Predictor_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
! *********** INTENT NEEDS TO BE CORRECTED TO JUST (IN) ***********
! *********** PREDICTOR CAN BE MODIFIED IN ODPS_AtmAbsorption MODULE ************
!
!       iVar:            Structure containing internal variables required for
!                        subsequent tangent-linear or adjoint model calls.
!                        The contents of this structure are NOT accessible
!                        outside of this module.
!                        UNITS:      N/A
!                        TYPE:       iVar_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!        AtmOptics:      Structure containing the computed optical depth
!                        profile.
!                        UNITS:      N/A
!                        TYPE:       CRTM_AtmOptics_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
!
! COMMENTS:
!       Note the INTENT on the output structure arguments are IN OUT rather
!       than just OUT. This is to prevent default reinitialisation upon entry.
!
!:sdoc-:
!------------------------------------------------------------------------------

  SUBROUTINE Compute_ODAS_AtmAbsorption( &
    SensorIndex  , &  ! Input
    ChannelIndex , &  ! Input
    Predictor    , &  ! Input
    AtmOptics    , &  ! Output
    iVar           )  ! Internal variable In/output
    ! Arguments
    INTEGER                  , INTENT(IN)     :: SensorIndex
    INTEGER                  , INTENT(IN)     :: ChannelIndex
    TYPE(ODAS_Predictor_type), INTENT(IN)     :: Predictor
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics
    TYPE(iVar_type)          , INTENT(IN OUT) :: iVar
    ! Variables
    REAL(fp) :: optical_depth( AtmOptics%n_Layers )

    ! Compute the optical depths
    ! ...At cell pressure 1
    CALL ODAS_Compute_AtmAbsorption( &
           TC(SensorIndex)%ODAS(iVar%Index_low), &
           ChannelIndex                        , &
           Predictor                           , &
           AtmOptics                           , &
           iVar%ODAS(1)                          )
    optical_depth = AtmOptics%Optical_Depth
    ! ...At cell pressure 2
    CALL ODAS_Compute_AtmAbsorption( &
           TC(SensorIndex)%ODAS(iVar%Index_low+1), &
           ChannelIndex                          , &
           Predictor                             , &
           AtmOptics                             , &
           iVar%ODAS(2)                            )
    ! ...Weighted average
    AtmOptics%Optical_Depth = iVar%Weight(1)*AtmOptics%Optical_Depth + &
                              iVar%Weight(2)*optical_depth

  END SUBROUTINE Compute_ODAS_AtmAbsorption

  SUBROUTINE Compute_ODPS_AtmAbsorption( &
    SensorIndex , &  ! Input
    ChannelIndex, &  ! Input
    Predictor   , &  ! Input
    AtmOptics   , &  ! Output
    iVar          )  ! Internal variable In/output
    ! Arguments
    INTEGER                  , INTENT(IN)     :: SensorIndex
    INTEGER                  , INTENT(IN)     :: ChannelIndex
    TYPE(ODPS_Predictor_type), INTENT(IN OUT) :: Predictor    ! INTENT! PREDICTOR CAN BE MODIFIED IN ODPS_AtmAbsorption MODULE
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics
    TYPE(iVar_type)          , INTENT(IN OUT) :: iVar
    ! Variables
    REAL(fp) :: optical_depth( AtmOptics%n_Layers )

    ! Compute the optical depths
    ! ...At cell pressure 1
    CALL ODPS_Compute_AtmAbsorption( &
           TC(SensorIndex)%ODPS(iVar%Index_low), &
           ChannelIndex                        , &
           Predictor                           , &
           AtmOptics                             )
    optical_depth = AtmOptics%Optical_Depth
    ! ...At cell pressure 2
    CALL ODPS_Compute_AtmAbsorption( &
           TC(SensorIndex)%ODPS(iVar%Index_low+1), &
           ChannelIndex                          , &
           Predictor                             , &
           AtmOptics                               )
    ! ...Weighted average
    AtmOptics%Optical_Depth = iVar%Weight(1)*AtmOptics%Optical_Depth + &
                              iVar%Weight(2)*optical_depth

  END SUBROUTINE Compute_ODPS_AtmAbsorption

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       ODSSU_Compute_AtmAbsorption_TL
!
! PURPOSE:
!       Subroutine to calculate the tangent-linear layer optical depths due
!       to gaseous absorption for the SSU sensor for a given channel and
!       atmospheric profile.
!
! CALLING SEQUENCE:
!       CALL ODSSU_Compute_AtmAbsorption_TL( SensorIndex , &
!                                            ChannelIndex, &
!                                            Predictor   , &
!                                            Predictor_TL, &
!                                            AtmOptics_TL, &
!                                            iVar          )
!
! INPUTS:
!       SensorIndex:     Sensor index id. This is a unique index associated
!                        with a (supported) sensor used to access the
!                        shared coefficient data for a particular sensor.
!                        See the ChannelIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       ChannelIndex:    Channel index id. This is a unique index associated
!                        with a (supported) sensor channel used to access the
!                        shared coefficient data for a particular sensor's
!                        channel.
!                        See the SensorIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       Predictor:       Structure containing the integrated absorber and
!                        predictor profile data.
!                        UNITS:      N/A
!                        TYPE:       ODAS_Predictor_type
!                                      or
!                                    ODPS_Predictor_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! *********** INTENT NEEDS TO BE CORRECTED TO JUST (IN) ***********
! *********** PREDICTOR_TL IS SPECIFIED AS INTENT(IN OUT) IN ODPS_AtmAbsorption MODULE ************
!       Predictor_TL:    Structure containing the tangent-linear integrated
!                        absorber and predictor profile data.
!                        UNITS:      N/A
!                        TYPE:       ODAS_Predictor_type
!                                      or
!                                    ODPS_Predictor_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
! *********** PREDICTOR_TL IS SPECIFIED AS INTENT(IN OUT) IN ODPS_AtmAbsorption MODULE ************
!
!       iVar:            Structure containing internal variables required for
!                        subsequent tangent-linear or adjoint model calls.
!                        The contents of this structure are NOT accessible
!                        outside of this module.
!                        UNITS:      N/A
!                        TYPE:       iVar_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!        AtmOptics_TL:   Structure containing the computed tangent-linear
!                        optical depth profile.
!                        UNITS:      N/A
!                        TYPE:       CRTM_AtmOptics_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
!
! COMMENTS:
!       Note the INTENT on the output structure arguments are IN OUT rather
!       than just OUT. This is to prevent default reinitialisation upon entry.
!
!:sdoc-:
!------------------------------------------------------------------------------

  SUBROUTINE Compute_ODAS_AtmAbsorption_TL( &
    SensorIndex , &  ! Input
    ChannelIndex, &  ! Input
    Predictor   , &  ! FWD Input
    Predictor_TL, &  ! TL  Input
    AtmOptics_TL, &  ! TL  Output
    iVar          )  ! Internal variable input
    ! Arguments
    INTEGER                  , INTENT(IN)     :: SensorIndex
    INTEGER                  , INTENT(IN)     :: ChannelIndex
    TYPE(ODAS_Predictor_type), INTENT(IN)     :: Predictor
    TYPE(ODAS_Predictor_type), INTENT(IN)     :: Predictor_TL
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics_TL
    TYPE(iVar_type)          , INTENT(IN)     :: iVar
    ! Variables
    REAL(fp) :: optical_depth_TL(AtmOptics_TL%n_Layers)

    ! Compute the tangent-linear optical depths
    ! ...At cell pressure 1
    CALL ODAS_Compute_AtmAbsorption_TL( &
           TC(SensorIndex)%ODAS(iVar%Index_low), &
           ChannelIndex                        , &
           Predictor                           , &
           Predictor_TL                        , &
           AtmOptics_TL                        , &
           iVar%ODAS(1)                          )
    optical_depth_TL = AtmOptics_TL%Optical_Depth
    ! ...At cell pressure 2
    CALL ODAS_Compute_AtmAbsorption_TL( &
           TC(SensorIndex)%ODAS(iVar%Index_low+1), &
           ChannelIndex                          , &
           Predictor                             , &
           Predictor_TL                          , &
           AtmOptics_TL                          , &
           iVar%ODAS(2)                            )
    ! ...Weighted average
    AtmOptics_TL%Optical_Depth = iVar%Weight(1)*AtmOptics_TL%Optical_Depth + &
                                 iVar%Weight(2)*optical_depth_TL

  END SUBROUTINE Compute_ODAS_AtmAbsorption_TL

  SUBROUTINE Compute_ODPS_AtmAbsorption_TL( &
    SensorIndex , &  ! Input
    ChannelIndex, &  ! Input
    Predictor   , &  ! FWD Input
    Predictor_TL, &  ! TL  Input
    AtmOptics_TL, &  ! TL  Output
    iVar          )  ! Internal variable input
    ! Arguments
    INTEGER                  , INTENT(IN)     :: SensorIndex
    INTEGER                  , INTENT(IN)     :: ChannelIndex
    TYPE(ODPS_Predictor_type), INTENT(IN)     :: Predictor
    TYPE(ODPS_Predictor_type), INTENT(IN OUT) :: Predictor_TL    ! INTENT! IS SPECIFIED AS (IN OUT) IN ODPS_AtmAbsorption MODULE
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics_TL
    TYPE(iVar_type)          , INTENT(IN)     :: iVar
    ! Variables
    REAL(fp) :: optical_depth_TL(AtmOptics_TL%n_Layers)

    ! Compute the tangent-linear optical depths
    ! ...At cell pressure 1
    CALL ODPS_Compute_AtmAbsorption_TL( &
           TC(SensorIndex)%ODPS(iVar%Index_low), &
           ChannelIndex                        , &
           Predictor                           , &
           Predictor_TL                        , &
           AtmOptics_TL                          )
    optical_depth_TL = AtmOptics_TL%Optical_Depth
    ! ...At cell pressure 2
    CALL ODPS_Compute_AtmAbsorption_TL( &
           TC(SensorIndex)%ODPS(iVar%Index_low+1), &
           ChannelIndex                          , &
           Predictor                             , &
           Predictor_TL                          , &
           AtmOptics_TL                            )
    ! ...Weighted average
    AtmOptics_TL%Optical_Depth = iVar%Weight(1)*AtmOptics_TL%Optical_Depth + &
                                 iVar%Weight(2)*optical_depth_TL

  END SUBROUTINE Compute_ODPS_AtmAbsorption_TL

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       ODSSU_Compute_AtmAbsorption_AD
!
! PURPOSE:
!       Subroutine to calculate the adjoint of the layer optical depths due
!       to gaseous absorption for the SSU sensor for a given channel and
!       atmospheric profile.
!
! CALLING SEQUENCE:
!       CALL ODSSU_Compute_AtmAbsorption_AD( SensorIndex , &
!                                            ChannelIndex, &
!                                            Predictor   , &
!                                            AtmOptics_AD, &
!                                            Predictor_AD, &
!                                            iVar          )
!
! INPUTS:
!       SensorIndex:     Sensor index id. This is a unique index associated
!                        with a (supported) sensor used to access the
!                        shared coefficient data for a particular sensor.
!                        See the ChannelIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       ChannelIndex:    Channel index id. This is a unique index associated
!                        with a (supported) sensor channel used to access the
!                        shared coefficient data for a particular sensor's
!                        channel.
!                        See the SensorIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       Predictor:       Structure containing the integrated absorber and
!                        predictor profile data.
!                        UNITS:      N/A
!                        TYPE:       ODAS_Predictor_type
!                                      or
!                                    ODPS_Predictor_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       AtmOptics_AD:    Structure containing the adjoint optical
!                        depth profile.
!                        *** NOTE: Optical depth component may be set to
!                                  zero upon exit.
!                        UNITS:      N/A
!                        TYPE:       CRTM_AtmOptics_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
!
!       iVar:            Structure containing internal variables required for
!                        subsequent tangent-linear or adjoint model calls.
!                        The contents of this structure are NOT accessible
!                        outside of this module.
!                        UNITS:      N/A
!                        TYPE:       iVar_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Predictor_AD:    Structure containing the adjoint integrated
!                        absorber and predictor profile data.
!                        *** NOTE: Must be defined upon entry.
!                        UNITS:      N/A
!                        TYPE:       Same as Predictor input argument.
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
!
! COMMENTS:
!       The contents of the input adjoint arguments are modified upon exit.
!
!:sdoc-:
!------------------------------------------------------------------------------

  SUBROUTINE Compute_ODAS_AtmAbsorption_AD( &
    SensorIndex , &  ! Input
    ChannelIndex, &  ! Input
    Predictor   , &  ! FWD Input
    AtmOptics_AD, &  ! AD  Input
    Predictor_AD, &  ! AD  Output
    iVar          )  ! Internal variable input
    ! Arguments
    INTEGER                  , INTENT(IN)     :: SensorIndex
    INTEGER                  , INTENT(IN)     :: ChannelIndex
    TYPE(ODAS_Predictor_type), INTENT(IN)     :: Predictor
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics_AD
    TYPE(ODAS_Predictor_type), INTENT(IN OUT) :: Predictor_AD
    TYPE(iVar_type)          , INTENT(IN)     :: iVar
    ! Variables
    REAL(fp) :: optical_depth_AD( AtmOptics_AD%n_Layers)

    ! Adjoint of weighted average optical depth
    optical_depth_AD           = iVar%Weight(2)*AtmOptics_AD%Optical_Depth
    AtmOptics_AD%Optical_Depth = iVar%Weight(1)*AtmOptics_AD%Optical_Depth

    ! Compute the adjoint of the optical depths
    ! ...At cell pressure #2
    CALL ODAS_Compute_AtmAbsorption_AD( &
           TC(SensorIndex)%ODAS(iVar%Index_low+1), &
           ChannelIndex                          , &
           Predictor                             , &
           AtmOptics_AD                          , &
           Predictor_AD                          , &
           iVar%ODAS(2)                            )
    AtmOptics_AD%Optical_Depth = AtmOptics_AD%Optical_Depth + optical_depth_AD
    ! ...At cell pressure #1
    CALL ODAS_Compute_AtmAbsorption_AD( &
           TC(SensorIndex)%ODAS(iVar%Index_low), &
           ChannelIndex                        , &
           Predictor                           , &
           AtmOptics_AD                        , &
           Predictor_AD                        , &
           iVar%ODAS(1)                          )

  END SUBROUTINE Compute_ODAS_AtmAbsorption_AD

  SUBROUTINE Compute_ODPS_AtmAbsorption_AD( &
    SensorIndex , &
    ChannelIndex, &
    Predictor   , &
    AtmOptics_AD, &
    Predictor_AD, &
    iVar          )
    ! Arguments
    INTEGER                  , INTENT(IN)     :: SensorIndex
    INTEGER                  , INTENT(IN)     :: ChannelIndex
    TYPE(ODPS_Predictor_type), INTENT(IN)     :: Predictor
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics_AD
    TYPE(ODPS_Predictor_type), INTENT(IN OUT) :: Predictor_AD
    TYPE(iVar_type)          , INTENT(IN)     :: iVar
    ! Variables
    REAL(fp) :: optical_depth_AD( AtmOptics_AD%n_Layers)

    ! Adjoint of weighted average optical depth
    optical_depth_AD           = iVar%Weight(2)*AtmOptics_AD%Optical_Depth
    AtmOptics_AD%Optical_Depth = iVar%Weight(1)*AtmOptics_AD%Optical_Depth

    ! Compute the adjoint of the optical depths
    ! ...At cell pressure #2
    CALL ODPS_Compute_AtmAbsorption_AD( &
           TC(SensorIndex)%ODPS(iVar%Index_low+1), &
           ChannelIndex                          , &
           Predictor                             , &
           AtmOptics_AD                          , &
           Predictor_AD                            )
    AtmOptics_AD%Optical_Depth = AtmOptics_AD%Optical_Depth + optical_depth_AD
    ! ...At cell pressure #1
    CALL ODPS_Compute_AtmAbsorption_AD( &
           TC(SensorIndex)%ODPS(iVar%Index_low), &
           ChannelIndex                        , &
           Predictor                           , &
           AtmOptics_AD                        , &
           Predictor_AD                          )

  END SUBROUTINE Compute_ODPS_AtmAbsorption_AD

    SUBROUTINE get_CO2_Cell_p(SensorIndex,ChannelIndex,u,y0)
! -------------------------------------------------------------------
!  Using an sensor "SensorIndex" and time "u" to find CO2 cell pressure "y0".
! -------------------------------------------------------------------
       INTEGER, INTENT( IN ) :: SensorIndex, ChannelIndex
       REAL(fp), INTENT( IN ) :: u
       REAL(fp), INTENT( OUT ) :: y0
       INTEGER :: n, jLower, jUpper, indx

       n = SIZE(TC(SensorIndex)%Ref_Time)
       jLower = 1
       jUpper = n

       if(u.ge.TC(SensorIndex)%Ref_Time(n)) then
         y0 = TC(SensorIndex)%Ref_CellPressure(n,ChannelIndex)
       return
       else if(u.le.TC(SensorIndex)%Ref_Time(1)) then
         y0 = TC(SensorIndex)%Ref_CellPressure(1,ChannelIndex)
       return
       endif

       indx = Bisection_Search( TC(SensorIndex)%Ref_Time, u )

       y0 = TC(SensorIndex)%Ref_CellPressure(indx,ChannelIndex) + &
          (TC(SensorIndex)%Ref_CellPressure(indx+1,ChannelIndex)- &
          TC(SensorIndex)%Ref_CellPressure(indx,ChannelIndex))/  &
          (TC(SensorIndex)%Ref_Time(indx+1)-TC(SensorIndex)%Ref_Time(indx))* &
          (u-TC(SensorIndex)%Ref_Time(indx))
       RETURN
    END SUBROUTINE get_CO2_Cell_p
!

END MODULE ODSSU_AtmAbsorption


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 honey(itmp,xx,nclu,time)
c see Honeycut & Anderson J. Phys. Chem. 91, 4950 (1987).

      implicit none
      include 'param.f'
      include 'c_output.f'

      integer nmax
      parameter(nmax=10)
      integer i,j,k,ii,nclu,ind1,ind2,ind3,isav(nmax),
     & isav2(nclu),k1,k2,nhit,itmp
      double precision xx(3,mnat),rij,rjk,rik,rkk,rcut,time,
     & haparam(0:nmax,0:nmax,0:nmax),tmph(10)

c cutoff for first shell
      rcut = 3.5d0/autoang
      rcut = rcut**2

      nhit = 0
      do i=0,nmax
      do j=0,nmax
      do k=0,nmax
        haparam(i,j,k) = 0.d0
      enddo
      enddo
      enddo
      do i=1,nclu
        do j=i+1,nclu
          ind1 = 0
          ind2 = 0
          ind3 = 0
          do ii=1,nmax
            isav(ii)=0
          enddo
          do ii=1,nclu
            isav2(ii)=0
          enddo
          rij = 0.d0
          do ii=1,3
          rij = rij + (xx(ii,i)-xx(ii,j))**2
          enddo
          if (rij.le.rcut) then
            do 10 k=1,nclu
            if (k.eq.i.or.k.eq.j) go to 10
              rik = 0.d0
              rjk = 0.d0
              do ii=1,3
                rik = rik + (xx(ii,i)-xx(ii,k))**2
                rjk = rjk + (xx(ii,j)-xx(ii,k))**2
              enddo
              if (rik.le.rcut.and.rjk.le.rcut.and.ind1.le.nmax) then
                ind1 = ind1 + 1
                isav(ind1)=k
              endif
  10        continue
            do k1=1,ind1
            do k2=k1+1,ind1
              rkk = 0.d0
              do ii=1,3
                rkk = rkk + (xx(ii,isav(k1))-xx(ii,isav(k2)))**2
              enddo
              if (rkk.le.rcut) then
                ind2 = ind2 + 1
                isav2(k1) = isav2(k1) + 1
                isav2(k2) = isav2(k2) + 1
              endif
            enddo
            enddo
            ind3 = 1
            do k1=1,ind1
              if (isav2(k1).ge.2) ind3 = 2
            enddo
            nhit = nhit + 1
            if (ind1.ge.0.and.ind2.ge.0.and.ind3.ge.0) then
            if (ind1.le.nmax.and.ind2.le.nmax.and.ind3.le.nmax) then
            haparam(ind1,ind2,ind3) = haparam(ind1,ind2,ind3) + 1.d0
            endif
            endif
          endif
        enddo
      enddo

c      do i=0,nmax
c      do j=0,nmax
c      do k=0,nmax
c        if (haparam(i,j,k).gt.0.d0) write(45,100)i,j,k,
c     & haparam(i,j,k)/dble(nhit)
c      enddo
c      enddo
c      enddo
c      write(45,*)
c 100  format(3i5,f15.5)

       tmph(1) = 0.d0
       tmph(2) = 0.d0
       tmph(3) = 0.d0
       tmph(4) = 0.d0
       tmph(5) = 0.d0
       do i=0,nmax
       tmph(1) = tmph(1) + haparam(2,i,1) + haparam(2,i,2)
       tmph(2) = tmph(2) + haparam(3,i,1) + haparam(3,i,2)
       tmph(3) = tmph(3) + haparam(4,i,1) + haparam(4,i,2)
       tmph(4) = tmph(4) + haparam(5,i,1) + haparam(5,i,2)
       tmph(5) = tmph(5) + haparam(6,i,1) + haparam(6,i,2)
       enddo
       tmph(6) = haparam(4,2,1)
       tmph(7) = haparam(4,2,2)

       if (lwrite(42)) write(42,101)itmp,time*autofs,
     & (tmph(k)/dble(nhit),k=1,7)
 101   format(i7,100f10.3)

      return

      end


C$Procedure      CKPFS ( C-kernel, get pointing from segment )

      SUBROUTINE CKPFS ( HANDLE, DESCR, SCLKDP, TOL,  NEEDAV,
     .                   CMAT,   AV,    CLKOUT, FOUND         )

C$ Abstract
C
C     Evaluate pointing data from a segment for a given time.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     CK
C     DAF
C
C$ Keywords
C
C     POINTING
C
C$ Declarations

      INCLUDE               'ckparam.inc'

      INTEGER               HANDLE
      DOUBLE PRECISION      DESCR  ( *    )
      DOUBLE PRECISION      SCLKDP
      DOUBLE PRECISION      TOL
      LOGICAL               NEEDAV
      DOUBLE PRECISION      CMAT   ( 3, 3 )
      DOUBLE PRECISION      AV     ( 3    )
      DOUBLE PRECISION      CLKOUT
      LOGICAL               FOUND

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   CK file handle.
C     DESCR      I   Segment descriptor.
C     SCLKDP     I   Spacecraft clock time.
C     TOL        I   Time tolerance.
C     NEEDAV     I   True when angular velocity data is requested.
C     CMAT       O   C-matrix.
C     AV         O   Angular velocity vector.
C     CLKOUT     O   Output spacecraft clock time.
C     FOUND      O   True when requested pointing is available.
C
C$ Detailed_Input
C
C     HANDLE     is the handle of the binary CK file containing the
C                desired segment. The file should have been opened
C                for read access, either by CKLPF or DAFOPR.
C
C     DESCR      is the packed descriptor of the segment.
C
C     SCLKDP     is the encoded spacecraft clock time for which
C                pointing is desired.
C
C     TOL        is a time tolerance, measured in the same units as
C                encoded spacecraft clock.  The C-matrix returned by
C                CKPFS is the one whose time is closest to SCLKDP and
C                within TOL units of SCLKDP.
C
C     NEEDAV     is true when angular velocity data is requested.
C
C
C$ Detailed_Output
C
C     CMAT       is a rotation matrix that transforms the components of
C                of a vector expressed in the reference frame given in
C                the segment to components expressed in the instrument
C                fixed frame at time CLKOUT.
C
C                Thus, if a vector v has components x, y, z in the
C                CK base frame, then v has components x', y', z' in
C                the instrument fixed frame at time CLKOUT:
C
C                     [ x' ]     [          ] [ x ]
C                     | y' |  =  |   CMAT   | | y |
C                     [ z' ]     [          ] [ z ]
C
C                If the x', y', z' components are known, use the
C                transpose of the C-matrix to determine x, y, z as
C                follows.
C
C                     [ x ]      [          ]T    [ x' ]
C                     | y |  =   |   CMAT   |     | y' |
C                     [ z ]      [          ]     [ z' ]
C                             (Transpose of CMAT)
C
C     AV         is the angular velocity vector. This is returned only
C                if it has been requested, as indicated by NEEDAV. In
C                other words, if NEEDAV is true, then the pointing
C                records in the segment must contain AV data.
C
C                The angular velocity vector is the right-handed axis
C                about which the reference frame tied to the instrument
C                is instantaneously rotating at time CLKOUT. The
C                magnitude of AV is the magnitude of the instantaneous
C                velocity of the rotation, in radians per second.
C
C                The components of AV are given relative to the
C                reference frame specified in the segment descriptor.
C
C     CLKOUT     is the encoded spacecraft clock time associated with
C                the returned C-matrix and, optionally, the returned
C                angular velocity vector.
C
C     FOUND      is true if a C-matrix and an angular velocity vector
C                (if requested) were found to satisfy the pointing
C                request. FOUND will be false otherwise.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the data type of the segment is not one of those supported
C         by this routine, the error SPICE(CKUNKNOWNDATATYPE) is
C         signaled.
C
C     2)  If the specified handle does not belong to any file that is
C         currently known to be open, an error is diagnosed by a
C         routine that this routine calls.
C
C     3)  If DESCR is not a valid, packed descriptor of a segment in
C         the CK file specified by HANDLE, the results of this routine
C         are unpredictable.
C
C     4)  If TOL is negative, FOUND is false.
C
C     5)  If NEEDAV is true, but the segment doesn't contain AV data,
C         an error is signaled by a routine that this routine calls.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The structure of this routine is just a big case statement. Each
C     segment data type is supported by two routines:
C
C        CKRnn   which reads a single logical pointing record from a
C                segment of type nn.  (A logical record is defined as
C                a collection of numbers sufficient to determine the
C                C-matrix, and optionally the angular velocity vector,
C                at the input time.)
C
C        CKEnn   which evaluates the pointing record returned by CKRnn
C                to give the C-matrix and optionally the angular
C                velocity vector at the input time.
C
C     The data type is determined from the segment descriptor, and the
C     appropriate routines are called.
C
C$ Examples
C
C     CKPFS allows you to be more selective than CKGP or CKGPAV about
C     choosing segments to satisfy CK pointing requests.
C
C     Suppose MOC.BC is a CK file consisting of several segments
C     containing Mars Observer Camera pointing data. Each segment
C     covers the same time period, but produces different pointing
C     values (one segment may contain predict values, another may
C     contain telemetry-based values, and others may contain different
C     corrected versions).
C
C     The following code fragment shows how different the results are
C     for each segment. The program steps through the file segment by
C     segment and requests pointing for the same time from each
C     segment. The results are printed to the screen.
C
C     GETIME is an imaginary routine used to get an encoded SCLK time
C     (SCLKDP) and time tolerance from the user.
C
C           SC     = -94
C           INST   = -94001
C           NEEDAV = .TRUE.
C
C           CALL CKLPF ( 'MOC.BC', HANDLE )
C
C           CALL GETIME ( SCLKDP, TOL, QUIT )
C
C     C
C     C     For each time, begin a forward search through the file, and
C     C     for each segment found, get its descriptor, identifier, and
C     C     evaluate the pointing.
C     C
C           DO WHILE ( .NOT. QUIT )
C
C              CALL DAFBFS ( HANDLE )
C              CALL DAFFNA ( FOUND  )
C
C              DO WHILE ( FOUND )
C
C                 CALL DAFGS ( DESCR )
C                 CALL DAFGN ( IDENT )
C
C                 CALL CKPFS ( HANDLE, DESCR, SCLKDP, TOL,   NEEDAV,
C          .                   CMAT,   AV,    CLKOUT, PFOUND         )
C
C                 IF ( PFOUND ) THEN
C                    WRITE (*,*) 'Segment:          ', IDENT
C                    WRITE (*,*) 'C-Matrix:         ', CMAT
C                    WRITE (*,*) 'Angular velocity: ', AV
C
C                 ELSE
C                    CALL SCDECD ( SC, SCLKDP, SCLKCH )
C                    WRITE (*,*) 'Data not found at time ', SCLKCH
C
C                 END IF
C
C                 CALL DAFFNA ( FOUND )
C
C              END DO
C
C              CALL GETIME ( SCLKDP, TOL, QUIT )
C
C           END DO
C
C
C$ Restrictions
C
C     A C-kernel file should have been loaded by either CKLPF
C     or DAFOPR.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     J.M. Lynch     (JPL)
C     B.V. Semenov   (JPL)
C     M.J. Spencer   (JPL)
C     R.E. Thurman   (JPL)
C     I.M. Underwood (JPL)
C
C$ Version
C
C-    SPICELIB Version 6.0.0, 24-MAR-2014 (NJB)
C
C        Bug fix: this routine now sets the output FOUND to
C        .FALSE. if a SPICE error is detected.
C
C        The routine was updated to handle data type 6 segments.
C        Several comment typos were corrected.
C
C-    SPICELIB Version 5.0.0, 19-AUG-2002 (NJB)
C
C        The routine was updated to handle data type 5 segments.
C
C-    SPICELIB Version 4.0.0, 02-MAY-1999 (BVS)
C
C        The routine was updated to handle data type 4 segments.
C        The RECSIZ size parameter was eliminated. The dimension
C        of the RECORD buffer is now defined by the CKMRSZ parameter
C        specified in the 'ckparam.inc' include file.
C
C-    SPICELIB Version 3.0.0, 11-SEP-1992 (JML)
C
C        The routine was updated to handle data type 3 segments.
C
C-    SPICELIB Version 2.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 2.0.0, 30-AUG-1991 (JML)
C
C         The routine was updated to handle data type 2 segments.
C
C         FOUND is now initialized to false.
C
C-    SPICELIB Version 1.0.1, 02-NOV-1990 (JML)
C
C         The restriction that a C-kernel file must be loaded
C         was explicitly stated.
C
C
C-    SPICELIB Version 1.0.0, 07-SEP-1990 (RET) (IMU)
C
C-&

C$ Index_Entries
C
C     get pointing from ck segment
C
C-&

C$ Revisions
C
C-    SPICELIB Version 6.0.0, 01-FEB-2014 (NJB)
C
C        The routine was updated to handle data type 6 segments.
C
C-    SPICELIB Version 5.0.0, 19-AUG-2002 (NJB)
C
C        The routine was updated to handle data type 5 segments.
C
C-    SPICELIB Version 4.0.0, 02-MAY-1999 (BVS)
C
C        The routine was updated to handle data type 4 segments.
C
C           a) 'ckparam.inc' include file was included.
C
C           b) RECSIZ size parameter was eliminated.
C
C           c) Size of the RECORD was reset to CKMRSZ, parameter
C              defined in the 'ckparam.inc' include file.
C
C           d) Calls to CKR04 and CKE04 were added to the case
C              statement.
C
C-    SPICELIB Version 3.0.0, 11-SEP-1992 (JML)
C
C        The routine was updated to handle data type 3 segments.
C
C           a) RECSIZ was increased to 17.
C
C           b) Calls to CKR03 and CKE03 were added to the case
C              statement.
C
C-    SPICELIB Version 2.0.0, 30-AUG-1991 (JML)
C
C        1) The routine was updated to handle data type 2 segments.
C
C        2) FOUND is initialized to false to guard against it being
C           left unchanged from its previous value when an error is
C           detected.
C
C-    SPICELIB Version 1.0.1, 02-NOV-1990 (JML)
C
C        1) The restriction that a C-kernel file must be loaded
C           was explicitly stated.
C
C-    Beta Version 1.1.0, 30-AUG-1990 (MJS)
C
C        The following changes were made as a result of the
C        NAIF CK Code and Documentation Review:
C
C        1) The variable SCLK was changed to SCLKDP.
C        2) The declarations for the parameters RECSIZ, NDC, and NIC
C           were moved from the "Declarations" section of the header
C           to the "Local parameters" section of the code below the
C           header. These parameters are not meant to modified by
C           users.
C        3) The header was updated.
C        4) The comments in the code were improved.
C
C-    Beta Version 1.0.0, 07-MAY-1990 (RET) (IMU)
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C
C        NDC        is the number of double precision components in an
C                   unpacked C-kernel segment descriptor.
C
C        NIC        is the number of integer components in an unpacked
C                   C-kernel segment descriptor.
C
      INTEGER               NDC
      PARAMETER           ( NDC    = 2  )

      INTEGER               NIC
      PARAMETER           ( NIC    = 6  )

C
C     Local variables
C
      INTEGER               ICD    ( NIC    )
      INTEGER               TYPE

      DOUBLE PRECISION      DCD    ( NDC    )
      DOUBLE PRECISION      RECORD ( CKMRSZ )

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'CKPFS' )
      END IF

C
C     Start off with FOUND set to false.
C
      FOUND  = .FALSE.

C
C     Upgrading CKPFS to accommodate new data types involves following
C     these steps:
C
C     1)  Write the two new routines CKRnn and CKEnn. (You may need to
C         add or subtract from the arguments used in the existing CKRnn
C         and CKEnn calling sequences, but should not have to change
C         the inputs or outputs to CKPFS.)
C
C     2)  Insert a new case into the code of CKPFS.
C
C     3)  Depending on the size of RECORD returned from CKRnn, modify
C         the parameter RECSIZ.  (You will only need to change it if
C         RECSIZ is not large enough for the new CKRnn's RECORD.)
C

C
C     Unpack the descriptor to see what the data type of the segment is,
C     and call the appropriate read-and-evaluate routines.
C
      CALL DAFUS ( DESCR, NDC, NIC, DCD, ICD )

      TYPE = ICD( 3 )

      IF ( TYPE .EQ. 1 ) THEN

         CALL CKR01 ( HANDLE, DESCR, SCLKDP, TOL, NEEDAV, RECORD,
     .                FOUND )

         IF ( FOUND ) THEN
            CALL CKE01 ( NEEDAV, RECORD, CMAT, AV, CLKOUT )
         END IF

      ELSE  IF ( TYPE .EQ. 2 ) THEN

         CALL CKR02 ( HANDLE, DESCR, SCLKDP, TOL, RECORD, FOUND )

         IF ( FOUND ) THEN
            CALL CKE02 ( NEEDAV, RECORD, CMAT, AV, CLKOUT )
         END IF

      ELSE  IF ( TYPE .EQ. 3 ) THEN

         CALL CKR03 (HANDLE, DESCR, SCLKDP, TOL, NEEDAV, RECORD, FOUND)

         IF ( FOUND ) THEN
            CALL CKE03 ( NEEDAV, RECORD, CMAT, AV, CLKOUT )
         END IF

      ELSE  IF ( TYPE .EQ. 4 ) THEN

         CALL CKR04 (HANDLE, DESCR, SCLKDP, TOL, NEEDAV, RECORD, FOUND)

         IF ( FOUND ) THEN
            CALL CKE04 ( NEEDAV, RECORD, CMAT, AV, CLKOUT )
         END IF

      ELSE  IF ( TYPE .EQ. 5 ) THEN

         CALL CKR05 (HANDLE, DESCR, SCLKDP, TOL, NEEDAV, RECORD, FOUND)

         IF ( FOUND ) THEN
            CALL CKE05 ( NEEDAV, RECORD, CMAT, AV, CLKOUT )
         END IF

      ELSE  IF ( TYPE .EQ. 6 ) THEN

         CALL CKR06 (HANDLE, DESCR, SCLKDP, TOL, NEEDAV, RECORD, FOUND)

         IF ( FOUND ) THEN
            CALL CKE06 ( NEEDAV, RECORD, CMAT, AV, CLKOUT )
         END IF

      ELSE

         CALL SETMSG ( 'The data type # is not currently supported.' )
         CALL ERRINT ( '#', TYPE                                     )
         CALL SIGERR ( 'SPICE(CKUNKNOWNDATATYPE)'                    )

      END IF

C
C     In case an evaluator signaled an error, we check the SPICE
C     error status here. If a SPICE error occurred, indicate no
C     data were found.
C
      IF ( FAILED() ) THEN
         FOUND = .FALSE.
      END IF

      CALL CHKOUT ( 'CKPFS' )
      RETURN
      END


      SUBROUTINE LINKUP (*,NAME)
C
      IMPLICIT INTEGER (A-Z)
      EXTERNAL        LSHIFT,RSHIFT,ANDF,ORF,COMPLF
      DIMENSION       NAME(2)
      COMMON /MACHIN/ MACHX
      COMMON /LNKLST/ ITOP,IBOT,ISN,KIND,ITYPE,MASK1,MASK2,MASK3
      COMMON /ZZZZZZ/ Z(1)
C
C     HASH INTO TABLE
C
      GO TO (10,10,10,20,30,30,10,30,30,30,   30,40,10,40,40,30,30,30,
     1       30,30,   30,30), MACHX
C
C     IBM AND UNIVAC
C
   10 ITOTAL = NAME(1) + NAME(2)
      GO TO 50
C
C     60-BIT MACHINE
C
   20 ITOTAL = RSHIFT(NAME(1),18) + RSHIFT(NAME(2),18)
      GO TO 50
C
C     32-BIT MACHINES
C
   30 ITOTAL = RSHIFT(NAME(1), 1) + RSHIFT(NAME(2), 1)
      GO TO 50
C
C     64-BIT MACHINES
C
   40 ITOTAL = RSHIFT(NAME(1),32) + RSHIFT(NAME(2),32)
C
   50 IHASH = 4*IABS(MOD(ITOTAL,250)) + 4
      K = ANDF(Z(IHASH),MASK1)
      IF (K.NE.0) GO TO 60
C
C     NO HASH CHAIN FOUND - CREATE CHAIN
C
      Z(IHASH) = Z(IHASH) + ITOP
      GO TO 90
C
C     HASH CHAIN FOUND - CHECK PRESENCE OF NAME
C
   60 IF (Z(K).NE.NAME(1) .OR. Z(K+1).NE.NAME(2)) GO TO 70
      IKIND = RSHIFT(ANDF(Z(K+3),MASK3),28)
      IF ((IKIND+1)/2 .EQ. (KIND+1)/2) GO TO 100
   70 L = ANDF(Z(K+3),MASK2)
      IF (L .EQ. 0) GO TO 80
      K = RSHIFT(L,14)
      GO TO 60
   80 Z(K+3) = Z(K+3) + LSHIFT(ITOP,14)
C
C     NO ENTRY FOUND - CREATE ENTRY
C
   90 Z(ITOP  ) = NAME(1)
      Z(ITOP+1) = NAME(2)
      Z(ITOP+2) = LSHIFT(ITYPE,28)
      Z(ITOP+3) = Z(ITOP+3) + LSHIFT(IABS(KIND),28)
      ITOP = ITOP + 4
      IF (ITOP .GE. IBOT) RETURN 1
      IF (KIND .LT.    0) RETURN
      K = ITOP - 4
C
C     ADD STATEMENT NUMBER TO LIST
C
  100 L = ANDF(Z(K+2),MASK1)
      IF (L .NE. 0) GO TO 110
C
C     LIST IS EMPTY - START LIST
C
      Z(K+2) = Z(K+2) + IBOT
      GO TO 120
C
C     CHAIN ENTRY ON LIST
C
  110 L    = RSHIFT(ANDF(Z(K+2),MASK2),14)
      Z(L) = ANDF(Z(L),COMPLF(MASK2))
      Z(L) = ORF(Z(L),LSHIFT(IBOT,14))
C
C     ADD ENTRY TO LIST
C
  120 Z(IBOT)= ORF(LSHIFT(KIND,28),ISN)
      Z(K+2) = ANDF(Z(K+2),COMPLF(MASK2))
      Z(K+2) = Z(K+2) + LSHIFT(IBOT,14)
      IBOT   = IBOT - 1
      IF (ITOP .GE. IBOT) RETURN 1
      RETURN
      END


      subroutine writea

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine writes annual output

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bio_yrms(:) |metric tons/ha|annual biomass (dry weight) in the HRU
!!    ch_d(:)     |m             |average depth of main channel
!!    ch_s(2,:)   |m/m           |average slope of main channel
!!    ch_w(2,:)   |m             |average width of main channel
!!    curyr       |none          |current year of simulation (consecutive)
!!    hrupest(:)  |none          |pesticide use flag:
!!                               | 0: no pesticides used in HRU
!!                               | 1: pesticides used in HRU
!!    hrupsty(:,1,:)|mg pst      |amount of pesticide type in surface runoff
!!                               |contribution to stream from HRU during year
!!                               |(in solution)
!!    hrupsty(:,2,:)|mg pst      |amount of pesticide type in surface runoff
!!                               |contribution to stream from HRU during year
!!                               |(sorbed to sediment)
!!    hruyro(:,:) |varies        |HRU annual output array
!!    i           |julian date   |current day of simulation
!!    id1         |julian date   |first day of simulation in current year
!!    ideg        |none          |channel degredation code
!!                               |0: do not compute channel degradation
!!                               |1: compute channel degredation (downcutting
!!                               |   and widening)
!!    iprint      |none          |print code:
!!                               |0 monthly
!!                               |1 daily
!!                               |2 annually
!!    isproj      |none          |special project code:
!!                               |1 test rewind (run simulation twice)
!!    iyr         |year          |current year of simulation (eg 1980)
!!    lai_yrmx(:) |none          |maximum leaf area index for the year in the
!!                               |HRU
!!    i_mo        |none          |month of next day of simulation
!!    mo_chk      |none          |month of current day of simulation
!!    nhru        |none          |number of HRUs in watershed
!!    npmx        |none          |number of different pesticides used in
!!                               |the simulation
!!    nres        |none          |total number of reservoirs in the
!!                               |watershed
!!    nyskip      |none          |number of years to skip output summarization
!!                               |and printing
!!    rchyro(:,:) |varies        |reach annual output array
!!    res_seci(:) |m             |secchi-disk depth
!!    res_vol(:)  |m^3 H2O       |reservoir volume
!!    resouty(1,:)|m^3/s         |flow into reservoir during year
!!    resouty(2,:)|m^3/s         |flow out of reservoir during year
!!    resouty(3,:)|metric tons   |sediment entering reservoir during year
!!    resouty(4,:)|metric tons   |sediment leaving reservoir during year
!!    resouty(5,:)|mg/L          |sediment concentration in reservoir
!!                               |during year
!!    resouty(6,:)|mg pst        |pesticide entering reservoir during year
!!    resouty(7,:)|mg pst        |pesticide lost from reservoir through
!!                               |reactions during year
!!    resouty(8,:)|mg pst        |pesticide lost from reservoir through
!!                               |volatilization during year
!!    resouty(9,:)|mg pst        |pesticide moving from water to sediment
!!                               |through settling during year
!!    resouty(10,:)|mg pst        |pesticide moving from sediment to water
!!                               |through resuspension during year
!!    resouty(11,:)|mg pst        |pesticide moving from water to sediment
!!                               |through diffusion during year
!!    resouty(12,:)|mg pst        |pesticide lost from reservoir sediment layer
!!                               |through reactions during year
!!    resouty(13,:)|mg pst        |pesticide lost from reservoir sediment layer
!!                               |through burial during year
!!    resouty(14,:)|mg pst        |pesticide transported out of reservoir during
!!                               |year
!!    resouty(15,:)|mg pst/m^3    |pesticide concentration in reservoir water
!!                               |during year
!!    resouty(16,:)|mg pst/m^3    |pesticide concentration in reservoir sediment
!!                               |layer during year
!!    resouty(17,:)|m^3 H2O       |evaporation from reservoir during year
!!    resouty(18,:)|m^3 H2O       |seepage from reservoir during year
!!    resouty(19,:)|m^3 H2O       |precipitation on reservoir during year
!!    resouty(22,:)|kg N          |organic N entering reservoir during year
!!    resouty(23,:)|kg N          |organic N leaving reservoir during year
!!    resouty(24,:)|kg P          |organic P entering reservoir during year
!!    resouty(25,:)|kg P          |organic P leaving reservoir during year
!!    resouty(26,:)|kg N          |nitrate entering reservoir during year
!!    resouty(27,:)|kg N          |nitrate leaving reservoir during year
!!    resouty(28,:)|kg N          |nitrite entering reservoir during year
!!    resouty(29,:)|kg N          |nitrite leaving reservoir during year
!!    resouty(30,:)|kg N          |ammonia entering reservoir during year
!!    resouty(31,:)|kg N          |ammonia leaving reservoir during year
!!    resouty(32,:)|kg P          |mineral P entering reservoir during year
!!    resouty(33,:)|kg P          |mineral P leaving reservoir during year
!!    resouty(34,:)|kg chla       |chlorophyll-a entering reservoir during year
!!    resouty(35,:)|kg chla       |chlorophyll-a leaving reservoir during year
!!    resouty(36,:)|mg P/L        |organic P concentration in reservoir water
!!                               |during year
!!    resouty(37,:)|mg P/L        |mineral P concentration in reservoir water
!!                               |during year
!!    resouty(38,:)|mg N/L        |organic N concentration in reservoir water
!!                               |during year
!!    resouty(39,:)|mg N/L        |nitrate concentration in reservoir water
!!                               |during year
!!    resouty(40,:)|mg N/L        |nitrite concentration in reservoir water
!!                               |during year
!!    resouty(41,:)|mg N/L        |ammonia concentration in reservoir water
!!                               |during year
!!    subtot      |none          |number of subbasins in watershed
!!    subyro(:,:) |varies        |subbasin annual output array
!!    wshddayo(35)|mm H2O        |amount of water stored in soil profile in
!!                               |watershed at end of day
!!    wshdyro(1)  |mm H2O        |average amount of precipitation in watershed
!!                               |for the year
!!    wshdyro(3)  |mm H2O        |surface runoff in watershed for year
!!    wshdyro(4)  |mm H2O        |lateral flow contribution to streamflow in
!!                               |watershed for year
!!    wshdyro(5)  |mm H2O        |water percolation past bottom of soil profile
!!                               |in watershed for year
!!    wshdyro(6)  |mm H2O        |water yield to streamflow from HRUs in
!!                               |watershed for year
!!    wshdyro(7)  |mm H2O        |actual evapotranspiration in watershed
!!                               |for year
!!    wshdyro(8)  |deg C         |average maximum temperature in watershed for
!!                               |the year
!!    wshdyro(9)  |deg C         |average minimum temperature in watershed for
!!                               |the year
!!    wshdyro(12) |metric tons   |sediment yield from HRUs in watershed for
!!                               |the year
!!    wshdyro(40) |kg N/ha       |organic N loading to stream in watershed for
!!                               |the year
!!    wshdyro(41) |kg P/ha       |organic P loading to stream in watershed for
!!                               |the year
!!    wshdyro(42) |kg N/ha       |nitrate loading to stream in surface runoff
!!                               |in watershed for the year
!!    wshdyro(43) |kg P/ha       |soluble P loading to stream in watershed for
!!                               |the year
!!    wshdyro(44) |kg N/ha       |plant uptake of N in watershed for the year
!!    wshdyro(45) |kg N/ha       |nitrate loading to stream in lateral flow
!!                               |in watershed for the year
!!    wshdyro(46) |kg N/ha       |nitrate percolation past bottom of soil
!!                               |profile in watershed for the year
!!    wshdyro(104)|mm H2O        |groundwater contribution to stream in
!!                               |watershed for the year
!!    wshdyro(108)|mm H2O        |potential evapotranspiration in watershed
!!                               |for the year
!!    wshdyro(109)|mm H2O        |drainage tile flow contribution to stream
!!                               |in watershed for the year
!!    wtryr(:,:)  |varies        |HRU impoundment annual output array
!!    yldanu(:)   |metric tons/ha|annual yield (dry weight) in the HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bio_aams(:) |metric tons/ha|average annual biomass (dry weight) in HRU
!!    hruaao(:,:) |varies        |HRU average annual output array
!!    hrupsta(:,:,:)|varies      |HRU average annual pesticide output array
!!    hrupsty(:,:,:)|varies      |HRU annual pesticide output array
!!    hruyro(:,:) |varies        |HRU annual output array
!!    lai_aamx(:) |none          |average annual maximum leaf area index in
!!                               |HRU
!!    rchaao(:,:) |varies        |reach average annual output array
!!    rchyro(:,:) |varies        |reach annual output array
!!    resouta(:,:)|varies        |reservoir average annual output array
!!    resouty(:,:)|varies        |reservoir annual output array
!!    subaao(:,:) |varies        |subbasin average annual output array
!!    subyro(:,:) |varies        |subbasin annual output array
!!    wshdaao(:)  |varies        |watershed average annual output array
!!    wshdyro(:)  |varies        |watershed annual output array
!!    wtraa(:,:)  |varies        |HRU impoundment average annual output array
!!    wtryr(:,:)  |varies        |HRU impoundment annual output array
!!    yldaa(:)    |metric tons/ha|average annual yield (dry weight) in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    idlast      |none          |number of days simulated in year
!!    j           |none          |counter
!!    k           |none          |counter
!!    sum         |mg pst        |total pesticide loading for year
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Real
!!    SWAT: hruyr, impndyr, subyr, rchyr

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

      use parm

      integer :: j, k
      real :: sum

      if (i_mo <= mo_chk .or. (curyr == nbyr .and. i == idal)) then
        !! calculate average annual max and min temperature
        wshdyro(8) = wshdyro(8) / 12.
        wshdyro(9) = wshdyro(9) / 12.

          !! annual write-output.std
          if (iscen == 1) then
          write (26,6300) iyr, wshdyro(1), wshdyro(3), wshdyro(4),
     &            wshdyro(104), wshdyro(5), wshdyro(109), wshddayo(35),
     &            wshdyro(7), wshdyro(108), wshdyro(6), wshdyro(12),
     &            wshdyro(42), wshdyro(45), wshdyro(46), wshdyro(44),
     &            wshdyro(40), wshdyro(43), wshdyro(41), wshdyro(111)
          else if (isproj == 1) then
          write (19,6300) iyr, wshdyro(1), wshdyro(3), wshdyro(4),
     &            wshdyro(104), wshdyro(5), wshdyro(109), wshddayo(35),
     &            wshdyro(7), wshdyro(108), wshdyro(6), wshdyro(12),
     &            wshdyro(42), wshdyro(45), wshdyro(46), wshdyro(44),
     &            wshdyro(40), wshdyro(43), wshdyro(41), wshdyro(111)
          endif

          !!write channel degradation data (chan.deg)
          if (ideg == 1) then
            write (16,780) iyr
            do j = 1, nrch
              write (16,779) j, ch_d(j), ch_w(2,j), ch_s(2,j)
            end do
          end if

        if (iprint /= 1) then
          !! annual write--pesticide output (output.pst) for HRUs
          do j = 1, nhru
            if (hrupest(j) == 1) then
            sum = 0.
            do k = 1, npmx
              sum = sum + hrupsty(k,1,j) + hrupsty(k,2,j)
            end do
            if (sum > 0. .and. iprp == 1) then
                write (30,5100) subnum(j), hruno(j), iyr,
     &                     (hrupsty(k,1,j), hrupsty(k,2,j), k = 1, npmx)
            end if
            end if
          end do

          !! annual write--HRU output (output.hru)
          call hruyr
          call impndyr

          !! annual write--subbasin output (output.sub)
          call subyr

          !! annual write--reach output (.rch)
          call rchyr

!         !! annual write--sediment routing (.sed)
          call rsedyr

          idlast = 0
          idlast = i - (id1 - 1)
          do j = 1, nres
            resouty(1,j) = resouty(1,j) / Real(idlast)
            resouty(2,j) = resouty(2,j) / Real(idlast)
            resouty(5,j) = resouty(5,j) / Real(idlast)
            resouty(15,j) = resouty(15,j) / Real(idlast)
            resouty(16,j) = resouty(16,j) / Real(idlast)
            resouty(36,j) = resouty(36,j) / Real(idlast)
            resouty(37,j) = resouty(37,j) / Real(idlast)
            resouty(38,j) = resouty(38,j) / Real(idlast)
            resouty(39,j) = resouty(39,j) / Real(idlast)
            resouty(40,j) = resouty(40,j) / Real(idlast)
            resouty(41,j) = resouty(41,j) / Real(idlast)
            if (iyr >= iyres(j)) then
              if (iscen == 1 .and. isproj == 0) then
              write (8,5800) j, iyr, res_vol(j), resouty(1,j),
     &                       resouty(2,j), resouty(19,j), resouty(17,j),
     &                       resouty(18,j), resouty(3,j), resouty(4,j),
     &                       resouty(5,j),
     &                       (resouty(k,j), k = 22, 23), resouty(38,j),
     &                       (resouty(k,j), k = 24, 25), resouty(36,j),
     &                       (resouty(k,j), k = 26, 27), resouty(39,j),
     &                       (resouty(k,j), k = 28, 29), resouty(40,j),
     &                       (resouty(k,j), k = 30, 31), resouty(41,j),
     &                       (resouty(k,j), k = 32, 33), resouty(37,j),
     &                       (resouty(k,j), k = 34, 35), res_seci(j),
     &                       (resouty(k,j), k = 6, 16)
              else if (isproj == 1) then
              write (22,5800) j, iyr, res_vol(j), resouty(1,j),
     &                       resouty(2,j), resouty(19,j), resouty(17,j),
     &                       resouty(18,j), resouty(3,j), resouty(4,j),
     &                       resouty(5,j),
     &                       (resouty(k,j), k = 22, 23), resouty(38,j),
     &                       (resouty(k,j), k = 24, 25), resouty(36,j),
     &                       (resouty(k,j), k = 26, 27), resouty(39,j),
     &                       (resouty(k,j), k = 28, 29), resouty(40,j),
     &                       (resouty(k,j), k = 30, 31), resouty(41,j),
     &                       (resouty(k,j), k = 32, 33), resouty(37,j),
     &                       (resouty(k,j), k = 34, 35), res_seci(j),
     &                       (resouty(k,j), k = 6, 16)
              else if (iscen == 1 .and. isproj == 2) then
              write (8,6800) j, iyr, res_vol(j), resouty(1,j),
     &                       resouty(2,j), resouty(19,j), resouty(17,j),
     &                       resouty(18,j), resouty(3,j), resouty(4,j),
     &                       resouty(5,j),
     &                       (resouty(k,j), k = 22, 23), resouty(38,j),
     &                       (resouty(k,j), k = 24, 25), resouty(36,j),
     &                       (resouty(k,j), k = 26, 27), resouty(39,j),
     &                       (resouty(k,j), k = 28, 29), resouty(40,j),
     &                       (resouty(k,j), k = 30, 31), resouty(41,j),
     &                       (resouty(k,j), k = 32, 33), resouty(37,j),
     &                       (resouty(k,j), k = 34, 35), res_seci(j),
     &                       (resouty(k,j), k = 6, 16), iyr

              endif
            end if
          end do
        end if

        if (curyr > nyskip) then
          do j = 1, nhru
            bio_aams(j) = bio_aams(j) + bio_yrms(j)
            lai_aamx(j) = lai_aamx(j) + lai_yrmx(j)
            yldaa(j) = yldaa(j) + yldanu(j)
          end do

          wshdaao = wshdaao + wshdyro
          wpstaao = wpstaao + wpstyro
          hruaao = hruaao + hruyro
          wtraa = wtraa + wtryr
          subaao = subaao + subyro
          rchaao = rchaao + rchyro
          resouta = resouta + resouty
          hrupsta = hrupsta + hrupsty
        end if

        wshdyro = 0.
        wpstyro = 0.
        hruyro = 0.
        wtryr = 0.
        subyro = 0.
        rchyro = 0.
        resouty = 0.
        hrupsty = 0.

      end if

      return
 777  format (i4,500e12.4)
 779  format (i4,3f12.4)
 780  format (/,' Year End',i5,' Channel Dimensions ',/,' Reach',
     &         '    Depth (m)','  Width (m)','  Slope (m/m)')
 5100 format (1x,a5,a4,1x,i4,4x,1x,250(e16.4,1x))
 5200 format (/,1x,i4,a4,1x,10f12.2)
 5300 format (1x,i4,a4,1x,10f12.2,/)
 5800 format ('RES   ',i8,1x,i4,41e12.4)
 6800 format ('RES   ',i8,1x,i4,41e12.4,1x,i4)
 6300 format (/i5,15f8.2,1x,5f8.2//)
      end


C$Procedure      SPKR09 ( Read SPK record from segment, type 9 )

      SUBROUTINE SPKR09 ( HANDLE, DESCR, ET, RECORD )
      IMPLICIT NONE

C$ Abstract
C
C     Read a single SPK data record from a segment of type 9
C     (Unequally spaced discrete states, interpolated by Lagrange
C     polynomials).
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     SPK
C
C$ Keywords
C
C     EPHEMERIS
C
C$ Declarations

      INTEGER               HANDLE
      DOUBLE PRECISION      DESCR    ( 5 )
      DOUBLE PRECISION      ET
      DOUBLE PRECISION      RECORD   ( * )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   File handle.
C     DESCR      I   Segment descriptor.
C     ET         I   Target epoch.
C     RECORD     O   Data record.
C
C$ Detailed_Input
C
C     HANDLE,
C     DESCR       are the file handle and segment descriptor for
C                 a SPK segment of type 9.
C
C     ET          is a target epoch, for which a data record from
C                 a specific segment is required.
C
C$ Detailed_Output
C
C     RECORD      is a set of data from the specified segment which,
C                 when evaluated at epoch ET, will give the state
C                 (position and velocity) of some body, relative
C                 to some center, in some inertial reference frame.
C
C                 The structure of the record is as follows:
C
C                    +----------------------+
C                    | number of states (n) |
C                    +----------------------+
C                    | state 1 (6 elts.)    |
C                    +----------------------+
C                    | state 2 (6 elts.)    |
C                    +----------------------+
C                                .
C                                .
C                                .
C                    +----------------------+
C                    | state n (6 elts.)    |
C                    +----------------------+
C                    | epochs 1--n          |
C                    +----------------------+
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     This routine follows the pattern established in the lower-numbered
C     SPK data type readers of not explicitly performing error
C     diagnoses.  Exceptions are listed below nonetheless.
C
C     1)  If the input HANDLE does not designate a loaded SPK file, the
C         error will be diagnosed by routines called by this routine.
C
C     2) If the segment specified by DESCR is not of data types 9 or 13,
C        the error 'SPICE(WRONGSPKTYPE)' is signalled.
C
C     3)  If the input ET value is not within the range specified
C         in the segment descriptor, the error SPICE(TIMEOUTOFBOUNDS)
C         is signalled.
C
C$ Files
C
C     See argument HANDLE.
C
C$ Particulars
C
C     See the SPK Required Reading file for a description of the
C     structure of a data type 9 segment.
C
C$ Examples
C
C     The data returned by the SPKRnn routine is in its rawest form,
C     taken directly from the segment.  As such, it will be meaningless
C     to a user unless he/she understands the structure of the data type
C     completely.  Given that understanding, however, the SPKRxx
C     routines might be used to "dump" and check segment data for a
C     particular epoch.
C
C
C     C
C     C     Get a segment applicable to a specified body and epoch.
C     C
C           CALL SPKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND )
C
C     C
C     C     Look at parts of the descriptor.
C     C
C           CALL DAFUS ( DESCR, 2, 6, DCD, ICD )
C           CENTER = ICD( 2 )
C           REF    = ICD( 3 )
C           TYPE   = ICD( 4 )
C
C           IF ( TYPE .EQ. 9 ) THEN
C              CALL SPKR09 ( HANDLE, DESCR, ET, RECORD )
C                  .
C                  .  Look at the RECORD data.
C                  .
C           END IF
C
C$ Restrictions
C
C     1)  Correctness of inputs must be ensured by the caller of
C         this routine.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.1.0, 07-SEP-2001 (EDW)
C
C        Replaced DAFRDA call with DAFGDA.
C        Added IMPLICIT NONE.
C
C-    SPICELIB Version 2.0.0, 06-NOV-1999 (NJB)
C
C        Data type check was relaxed to enable reading type 13
C        segments.
C
C-    SPICELIB Version 1.0.1, 24-OCT-1994 (NJB)
C
C        In-line comment concerning transpose of state data was
C        removed.
C
C-    SPICELIB Version 1.0.0,  14-AUG-1993 (NJB)
C
C-&

C$ Index_Entries
C
C     read record from type_9 spk segment
C
C-&

C$ Revisions
C
C-&

C
C     SPICELIB functions
C
      INTEGER               LSTLTD

      LOGICAL               ODD
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               ND
      PARAMETER           ( ND     = 2 )

      INTEGER               NI
      PARAMETER           ( NI     = 6 )

      INTEGER               STATSZ
      PARAMETER           ( STATSZ = 6 )

      INTEGER               DIRSIZ
      PARAMETER           ( DIRSIZ = 100 )

      INTEGER               BUFSIZ
      PARAMETER           ( BUFSIZ = DIRSIZ + 1 )

C
C     Local variables
C
      DOUBLE PRECISION      BUFFER ( BUFSIZ )
      DOUBLE PRECISION      CONTRL ( 2  )
      DOUBLE PRECISION      DC     ( ND )

      INTEGER               BEGIDX
      INTEGER               BEGIN
      INTEGER               BUFBAS
      INTEGER               DEGREE
      INTEGER               DIRBAS
      INTEGER               END
      INTEGER               ENDIDX
      INTEGER               FIRST
      INTEGER               GROUP
      INTEGER               HIGH
      INTEGER               I
      INTEGER               IC     ( NI )
      INTEGER               LAST
      INTEGER               LOW
      INTEGER               N
      INTEGER               NDIR
      INTEGER               NEAR
      INTEGER               NREAD
      INTEGER               REMAIN
      INTEGER               START
      INTEGER               TIMBAS
      INTEGER               TYPE
      INTEGER               WNDSIZ

C
C     Use discovery check-in.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

C
C     Unpack the segment descriptor, and get the start and end addresses
C     of the segment.
C
      CALL DAFUS ( DESCR, 2, 6, DC, IC )

      TYPE  = IC( 4 )
      BEGIN = IC( 5 )
      END   = IC( 6 )

C
C     Make sure that this really is a type 9 or type 13 data segment.
C
      IF (  ( TYPE .NE. 09 ) .AND. ( TYPE .NE. 13 )  ) THEN
         CALL CHKIN ( 'SPKR09'                                        )
         CALL SETMSG( 'You are attempting to locate type 9 or type ' //
     .                '13 data in a type # data segment.'             )
         CALL ERRINT( '#',  TYPE                                      )
         CALL SIGERR( 'SPICE(WRONGSPKTYPE)'                           )
         CALL CHKOUT( 'SPKR09'                                        )
         RETURN
      END IF

C
C     Check the request time against the bounds in the segment
C     descriptor.
C
      IF (  ( ET .LT. DC(1) )  .OR.  ( ET .GT. DC(2) )  )  THEN
         CALL CHKIN ( 'SPKR09'                                      )
         CALL SETMSG( 'Request time # is outside of descriptor '   //
     .                'bounds # : #.'                               )
         CALL ERRDP ( '#',  ET                                      )
         CALL ERRDP ( '#',  DC(1)                                   )
         CALL ERRDP ( '#',  DC(2)                                   )
         CALL SIGERR( 'SPICE(TIMEOUTOFBOUNDS)'                      )
         CALL CHKOUT( 'SPKR09'                                      )
         RETURN

      END IF
C
C     From this point onward, we assume the segment was constructed
C     correctly.  In particular, we assume:
C
C        1)  The first and last epochs in the segment define a time
C            interval that contains the interval defined by the segment
C            descriptor's time bounds.
C
C        2)  The segment descriptor's time bounds are in order and are
C            distinct.
C
C        3)  The epochs in the segment are in strictly increasing
C            order.
C
C        4)  The degree of the interpolating polynomial specified by
C            the segment is at least 1 and is no larger than
C
C               ( L - 1 ) / 7         [integer division]
C
C            where L is the declared length of the argument RECORD.
C
C        5)  There are at least as many epochs in the segment as the
C            the number of points required to define an interpolating
C            polynomial of the specified degree.
C
C
C     We'll need the last two items before we can determine which
C     states make up our output record.
C
C
      CALL DAFGDA ( HANDLE, END-1, END, CONTRL )

      DEGREE  =  NINT ( CONTRL(1) )
      N       =  NINT ( CONTRL(2) )

      WNDSIZ  =  DEGREE + 1

C
C     We'll now select the set of states that define the interpolating
C     polynomials.   We'll start out by finding the first directory
C     entry that is greater than or equal to the request epoch.  We'll
C     use the variable GROUP to indicate the set of epochs to search
C     within, once we've found the right directory entry.
C
      NDIR    =  (N-1) / DIRSIZ
      DIRBAS  =  END  -  NDIR  -  2

      IF ( NDIR .EQ. 0 ) THEN
C
C        There's no mystery about which group of epochs to search.
C
         GROUP  = 1

      ELSE
C
C        There's at least one directory.  Find the first directory
C        whose time is greater than or equal to the request time, if
C        there is such a directory.  We'll search linearly through the
C        directory entries, reading up to BUFSIZ of them at a time.
C        Having found the correct set of directory entries, we'll
C        perform a binary search within that set for the desired entry.
C
         BUFBAS  =  DIRBAS
         NREAD   =  MIN ( NDIR, BUFSIZ )
         REMAIN  =  NDIR - NREAD

         CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+NREAD, BUFFER )

         DO WHILE (       ( BUFFER(NREAD) .LT. ET )
     .              .AND. ( REMAIN        .GT. 0  )   )

            BUFBAS  =  BUFBAS + NREAD
            NREAD   =  MIN ( REMAIN, BUFSIZ )
            REMAIN  =  REMAIN - NREAD
C
C           Note:  NREAD is always > 0 here.
C
            CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+NREAD, BUFFER )

         END DO

C
C        At this point, BUFBAS - DIRBAS is the number of directory
C        entries preceding the one contained in BUFFER(1).
C
         GROUP  =     ( BUFBAS - DIRBAS )
     .              +   LSTLTD ( ET, NREAD, BUFFER )
     .              +   1

      END IF

C
C     GROUP now indicates the set of epochs in which to search for the
C     request epoch.  If GROUP is 1, the request time lies within the
C     inclusive time interval bounded by the first and last epochs of
C     the first group.  Otherwise, the request time lies in the time
C     interval bounded by the last element of the preceding group and
C     the last element of the current group.
C
C     We'll use the variable names BEGIDX and ENDIDX to refer to
C     the indices, relative to the set of time tags, of the first
C     and last time tags in the set we're going to look up.
C
      IF ( GROUP .EQ. 1 ) THEN

         BEGIDX  =  1
         ENDIDX  =  MIN ( N, DIRSIZ )

      ELSE
C
C        If the group index is greater than 1, we'll include the last
C        time tag of the previous group in the set of time tags we look
C        up.  That way, the request time is bracketed by the time tag
C        set we look up.
C
         BEGIDX  =      (  GROUP  - 1 ) * DIRSIZ
         ENDIDX  =  MIN (  BEGIDX + DIRSIZ,  N  )

      END IF

      TIMBAS  =  DIRBAS - N

      CALL DAFGDA ( HANDLE, TIMBAS+BEGIDX, TIMBAS+ENDIDX, BUFFER )

C
C     Find two adjacent epochs bounding the request epoch.  The request
C     time cannot be greater than all of epochs in the group, and it
C     cannot precede the first element of the group.
C
      I     =  LSTLTD (  ET,  ENDIDX-BEGIDX+1,  BUFFER  )

C
C     The variables LOW and high are the indices of a pair of time
C     tags that bracket the request time.
C
      IF ( I .EQ. 0 ) THEN
         LOW  =  1
      ELSE
         LOW  =  BEGIDX + I - 1
      END IF

      HIGH  =  LOW  +  1

C
C     Now select the set of states used for interpolation.
C
      IF ( ODD(WNDSIZ) ) THEN
C
C        Find the index of the state whose epoch is closest to the
C        input epoch.  The index I is in the range [0, DIRSIZ],
C        since ENDIDX - BEGIDX never exceeds DIRSIZ, and ET is
C        never larger than the (ENDIDX-BEGIDX+1)th element of the
C        buffer.
C
         IF ( I .EQ. 0 ) THEN
C
C           This can happen only if the request time matches the
C           first time tag of the segment.
C
            NEAR = LOW

         ELSE IF (       DABS(  ET  -  BUFFER(I)    )
     .             .LT.  DABS(  ET  -  BUFFER(I+1)  )    )  THEN

            NEAR = LOW

         ELSE
            NEAR = HIGH
         END IF

C
C        The epochs whose index is NEAR is the (WNDSIZ/2 + 1)th
C        of the interpolating set, unless the request time is too close
C        to the end of the coverage interval, in which case one endpoint
C        of the window will coincide with an endpoint of the coverage
C        interval.
C
         FIRST =  MIN (  MAX ( NEAR - DEGREE/2,  1),   N-DEGREE  )

         LAST  =  FIRST  +  DEGREE

      ELSE
C
C        The group size is even.
C
C        The bracketing epochs we've found are the (WNDSIZ/2)th
C        and (WNDSIZ/2 + 1)th of the interpolating set, unless the
C        request time is too close to the end of the coverage interval,
C        in which case one endpoint of the window will coincide with
C        an endpoint of the coverage interval.
C
         FIRST =  MIN (  MAX ( LOW - DEGREE/2,  1 ),   N-DEGREE  )

         LAST  =  FIRST  +  DEGREE

      END IF

C
C     Put the size of the group of states into the output record.
C
      RECORD(1) =  WNDSIZ

C
C     Read the states.
C
      CALL DAFGDA ( HANDLE,
     .              BEGIN + (FIRST-1)*STATSZ,
     .              BEGIN +      LAST*STATSZ  -  1,
     .              RECORD(2)                       )

C
C     Finally, add the epochs to the output record.
C
      START  =  BEGIN   +  N * STATSZ  +  FIRST - 2

      CALL DAFGDA (  HANDLE,
     .               START + 1,
     .               START + WNDSIZ,
     .               RECORD( 2 + WNDSIZ*STATSZ )   )

      RETURN
      END