!
! CRTM_RTSolution
!
! Module containing the CRTM radiative transfer solution routines.
!
!
! CREATION HISTORY:
!       Written by:     Quanhua Liu,    QSS at JCSDA;    Quanhua.Liu@noaa.gov
!                       Yong Han,       NOAA/NESDIS;     Yong.Han@noaa.gov
!                       Paul van Delst, CIMSS/SSEC;      paul.vandelst@ssec.wisc.edu
!                       08-Jun-2004

MODULE CRTM_RTSolution

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module use statements
  USE Type_Kinds              , ONLY: fp
  USE Message_Handler         , ONLY: SUCCESS, FAILURE, Display_Message
  USE CRTM_Parameters         , ONLY: ZERO, ONE, TWO, PI, &
                                      MAX_N_ANGLES, &
                                      RT_ADA, RT_SOI
  USE Common_RTSolution       , ONLY: Assign_Common_Input, &
                                      Assign_Common_Output, &
                                      Assign_Common_Input_TL, &
                                      Assign_Common_Output_TL, &
                                      Assign_Common_Input_AD, &
                                      Assign_Common_Output_AD
  USE CRTM_SpcCoeff           , ONLY: SC
  USE CRTM_Atmosphere_Define  , ONLY: CRTM_Atmosphere_type
  USE CRTM_Surface_Define     , ONLY: CRTM_Surface_type
  USE CRTM_GeometryInfo_Define, ONLY: CRTM_GeometryInfo_type
  USE CRTM_AtmOptics_Define   , ONLY: CRTM_AtmOptics_type
  USE CRTM_SfcOptics_Define   , ONLY: CRTM_SfcOptics_type
  USE CRTM_RTSolution_Define  , ONLY: CRTM_RTSolution_type
  USE CRTM_Utility
  USE RTV_Define
  ! RT modules
  USE SOI_Module
  USE ADA_Module
  USE Emission_Module
  ! Disable all implicit typing
  IMPLICIT NONE

  ! --------------------
  ! Default visibilities
  ! --------------------
  ! Everything private by default
  PRIVATE
  ! RTSolution structure entities
  ! ...Datatypes
  PUBLIC :: CRTM_RTSolution_type
  ! RTV structure entities
  ! ...Datatypes
  PUBLIC :: RTV_type
  ! Module procedures
  PUBLIC :: CRTM_Compute_RTSolution
  PUBLIC :: CRTM_Compute_RTSolution_TL
  PUBLIC :: CRTM_Compute_RTSolution_AD
  PUBLIC :: CRTM_Compute_nStreams
  PUBLIC :: CRTM_RTSolution_Version

  ! -----------------
  ! Module parameters
  ! -----------------
  ! Version Id for the module
  CHARACTER(*),  PARAMETER :: MODULE_VERSION_ID = &
  '$Id$'

CONTAINS

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

!--------------------------------------------------------------------------------
!
! NAME:
!       CRTM_Compute_RTSolution
!
! PURPOSE:
!       Function to solve the radiative transfer equation.
!
! CALLING SEQUENCE:
!       Error_Status = CRTM_Compute_RTSolution( Atmosphere  , &  ! Input
!                                               Surface     , &  ! Input
!                                               AtmOptics   , &  ! Input
!                                               SfcOptics   , &  ! Input
!                                               GeometryInfo, &  ! Input
!                                               SensorIndex , &  ! Input
!                                               ChannelIndex, &  ! Input
!                                               RTSolution  , &  ! Output
!                                               RTV           )  ! Internal variable output
!
! INPUT ARGUMENTS:
!       Atmosphere:     Structure containing the atmospheric state data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_Atmosphere_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       Surface:        Structure containing the surface state data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_Surface_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       AtmOptics:      Structure containing the combined atmospheric
!                       optical properties for gaseous absorption, clouds,
!                       and aerosols.
!                       UNITS:      N/A
!                       TYPE:       CRTM_AtmOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       SfcOptics:      Structure containing the surface optical properties
!                       data. Argument is defined as INTENT (IN OUT ) as
!                       different RT algorithms may compute the surface
!                       optics properties before this routine is called.
!                       UNITS:      N/A
!                       TYPE:       CRTM_SfcOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!       GeometryInfo:   Structure containing the view geometry data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_GeometryInfo_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)
!
! OUTPUT ARGUMENTS:
!       RTSolution:     Structure containing the soluition to the RT equation
!                       for the given inputs.
!                       UNITS:      N/A
!                       TYPE:       CRTM_RTSolution_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!       RTV:            Structure containing internal variables required for
!                       subsequent tangent-linear or adjoint model calls.
!                       The contents of this structure are NOT accessible
!                       outside of the CRTM_RTSolution module.
!                       UNITS:      N/A
!                       TYPE:       RTV_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(OUT)
!
! FUNCTION RESULT:
!       Error_Status:   The return value is an integer defining the error status.
!                       The error codes are defined in the Message_Handler module.
!                       If == SUCCESS the computation was sucessful
!                          == FAILURE an unrecoverable error occurred
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
! COMMENTS:
!       Note the INTENT on the output RTSolution argument is IN OUT rather than
!       just OUT. This is necessary because the argument is defined upon
!       input. To prevent memory leaks, the IN OUT INTENT is a must.
!
!--------------------------------------------------------------------------------

  FUNCTION CRTM_Compute_RTSolution( &
    Atmosphere  , &  ! Input
    Surface     , &  ! Input
    AtmOptics   , &  ! Input
    SfcOptics   , &  ! Input
    GeometryInfo, &  ! Input
    SensorIndex , &  ! Input
    ChannelIndex, &  ! Input
    RTSolution  , &  ! Output
    RTV         ) &  ! Internal variable output
  RESULT( Error_Status )
    ! Arguments
    TYPE(CRTM_Atmosphere_type),   INTENT(IN)     :: Atmosphere
    TYPE(CRTM_Surface_type),      INTENT(IN)     :: Surface
    TYPE(CRTM_AtmOptics_type),    INTENT(IN)     :: AtmOptics
    TYPE(CRTM_SfcOptics_type),    INTENT(IN OUT) :: SfcOptics
    TYPE(CRTM_GeometryInfo_type), INTENT(IN OUT) :: GeometryInfo
    INTEGER,                      INTENT(IN)     :: SensorIndex
    INTEGER,                      INTENT(IN)     :: ChannelIndex
    TYPE(CRTM_RTSolution_type),   INTENT(IN OUT) :: RTSolution
    TYPE(RTV_type),               INTENT(IN OUT) :: RTV
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Compute_RTSolution'
    ! Local variables
    CHARACTER(256) :: Message
    INTEGER :: i, nZ

    Error_Status = SUCCESS

    ! Populate the RTV structure
    Error_Status = Assign_Common_Input( Atmosphere  , &
                                        Surface     , &
                                        AtmOptics   , &
                                        SfcOptics   , &
                                        GeometryInfo, &
                                        SensorIndex , &
                                        ChannelIndex, &
                                        RTSolution  , &
                                        nz          , &
                                        RTV           )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error assigning input for RTSolution algorithms'
      CALL Display_Message( ROUTINE_NAME, TRIM(Message), Error_Status )
      RETURN
    END IF

    ! Direct reflectivity normalisation fix for visible sensors
    IF( RTV%Visible_Flag_true ) THEN
      DO i = 1, nZ
        SfcOptics%Direct_Reflectivity(i,1) = SfcOptics%Direct_Reflectivity(i,1) * PI
        ! ...Apply the UW limiter
        IF (SfcOptics%Direct_Reflectivity(i,1) > ONE) THEN
          SfcOptics%Direct_Reflectivity(i,1) = ONE
        END IF
      END DO
    END IF

    ! ------------------------------
    ! Perform the radiative transfer
    ! ------------------------------
    ! Select the RT model
    IF( RTV%Scattering_RT ) THEN

      ! Select the scattering RT model
      SELECT CASE(RTV%RT_Algorithm_Id)
        CASE (RT_ADA) ;
          RTSolution%RT_Algorithm_Name = 'ADA'
          ! NESDIS advanced adding-doubling method
          CALL CRTM_ADA( &
               Atmosphere%n_Layers                       , & ! Input, number of atmospheric layers
               AtmOptics%Single_Scatter_Albedo           , & ! Input, layer single scattering albedo
               AtmOptics%Optical_Depth                   , & ! Input, layer optical depth
               RTV%Cosmic_Background_Radiance            , & ! Input, cosmic background radiation
               SfcOptics%Emissivity( 1:nZ, 1 )           , & ! Input, surface emissivity
               SfcOptics%Reflectivity( 1:nZ, 1, 1:nZ, 1 ), & ! Input, surface reflectivity
               SfcOptics%Direct_Reflectivity(1:nZ,1)     , & ! Input, surface reflectivity for a point source
               RTV                                         ) ! Output, Internal variables
        CASE (RT_SOI) ;
          RTSolution%RT_Algorithm_Name = 'SOI'
          ! UW SOI RT solver
          CALL CRTM_SOI( &
                 Atmosphere%n_Layers                       , & ! Input, number of atmospheric layers
                 AtmOptics%Single_Scatter_Albedo           , & ! Input, layer single scattering albedo
                 AtmOptics%Optical_Depth                   , & ! Input, layer optical depth
                 RTV%Cosmic_Background_Radiance            , & ! Input, cosmic background radiation
                 SfcOptics%Emissivity( 1:nZ, 1 )           , & ! Input, surface emissivity
                 SfcOptics%Reflectivity( 1:nZ, 1, 1:nZ, 1 ), & ! Input, surface reflectivity
                 SfcOptics%Index_Sat_Ang                   , & ! Input, Satellite angle index
                 RTV                                         ) ! Output, Internal variables
      END SELECT

    ELSE

      ! -----------------
      ! Emission model RT
      ! -----------------
      RTSolution%RT_Algorithm_Name = 'Emission'
      CALL CRTM_Emission( &
             Atmosphere%n_Layers,                   & ! Input, number of atmospheric layers
             RTV%n_Angles,                          & ! Input, number of discrete zenith angles
             RTV%Diffuse_Surface,                   & ! Input, surface behavior
             GeometryInfo%Cosine_Sensor_Zenith,     & ! Input, cosine of sensor zenith angle
             AtmOptics%Optical_Depth,               & ! Input, layer optical depth
             RTV%Planck_Atmosphere,                 & ! Input, layer radiances
             RTV%Planck_Surface,                    & ! Input, surface radiance
             SfcOptics%Emissivity(1:nZ,1),          & ! Input, surface emissivity
             SfcOptics%Reflectivity(1:nZ,1,1:nZ,1), & ! Input, surface reflectivity
             SfcOptics%Direct_Reflectivity(1:nZ,1), & ! Input, surface reflectivity for a point source
             RTV%Cosmic_Background_Radiance,        & ! Input, cosmic background radiation
             RTV%Solar_Irradiance,                  & ! Input, Source irradiance at TOA
             RTV%Is_Solar_Channel,                  & ! Input, Source sensitive channel info.
             GeometryInfo%Source_Zenith_Radian,     & ! Input, Source zenith angle
             RTV                                    ) ! Output, Internal variables

    END IF

    Error_Status = Assign_Common_Output( Atmosphere,   &
                                         SfcOptics,    &
                                         GeometryInfo, &
                                         SensorIndex,  &
                                         ChannelIndex, &
                                         RTV,          &
                                         RTSolution    )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error assigning output for RTSolution algorithms'
      CALL Display_Message( ROUTINE_NAME, TRIM(Message), Error_Status )
      RETURN
    END IF

  END FUNCTION CRTM_Compute_RTSolution

!--------------------------------------------------------------------------------
!
! NAME:
!       CRTM_Compute_RTSolution_TL
!
! PURPOSE:
!       Function to solve the tangent-linear radiative transfer equation.
!
! CALLING SEQUENCE:
!      Error_Status = CRTM_Compute_RTSolution_TL( Atmosphere   , &  ! FWD Input
!                                                 Surface      , &  ! FWD Input
!                                                 AtmOptics    , &  ! FWD Input
!                                                 SfcOptics    , &  ! FWD Input
!                                                 RTSolution   , &  ! FWD Input
!                                                 Atmosphere_TL, &  ! TL Input
!                                                 Surface_TL   , &  ! TL Input
!                                                 AtmOptics_TL , &  ! TL Input
!                                                 SfcOptics_TL , &  ! TL Input
!                                                 GeometryInfo , &  ! Input
!                                                 SensorIndex  , &  ! Input
!                                                 ChannelIndex , &  ! Input
!                                                 RTSolution_TL, &  ! TL Output
!                                                 RTV            )  ! Internal variable input
!
! INPUT ARGUMENTS:
!       Atmosphere:     Structure containing the atmospheric state data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_Atmosphere_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       Surface:        Structure containing the surface state data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_Surface_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       AtmOptics:      Structure containing the combined atmospheric
!                       optical properties for gaseous absorption, clouds,
!                       and aerosols.
!                       UNITS:      N/A
!                       TYPE:       CRTM_AtmOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       SfcOptics:      Structure containing the surface optical properties
!                       data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_SfcOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       RTSolution:     Structure containing the solution to the RT equation
!                       for the given inputs.
!                       UNITS:      N/A
!                       TYPE:       CRTM_RTSolution_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       Atmosphere_TL:  Structure containing the tangent-linear atmospheric
!                       state data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_Atmosphere_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       Surface_TL:     Structure containing the tangent-linear surface state data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_Surface_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       AtmOptics_TL:   Structure containing the tangent-linear atmospheric
!                       optical properties.
!                       UNITS:      N/A
!                       TYPE:       CRTM_AtmOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       SfcOptics_TL:   Structure containing the tangent-linear surface optical
!                       properties. Argument is defined as INTENT (IN OUT ) as
!                       different RT algorithms may compute the surface optics
!                       properties before this routine is called.
!                       UNITS:      N/A
!                       TYPE:       CRTM_SfcOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT( IN OUT)
!
!       GeometryInfo:   Structure containing the view geometry data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_GeometryInfo_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)
!
!       RTV:            Structure containing internal forward model variables
!                       required for subsequent tangent-linear or adjoint model
!                       calls. The contents of this structure are NOT accessible
!                       outside of the CRTM_RTSolution module.
!                       UNITS:      N/A
!                       TYPE:       RTV_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(OUT)
!
! OUTPUT ARGUMENTS:
!       RTSolution_TL:  Structure containing the solution to the tangent-linear
!                       RT equation for the given inputs.
!                       UNITS:      N/A
!                       TYPE:       CRTM_RTSolution_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
! FUNCTION RESULT:
!       Error_Status:   The return value is an integer defining the error status
!                       The error codes are defined in the Message_Handler module.
!                       If == SUCCESS the computation was sucessful
!                          == FAILURE an unrecoverable error occurred
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
! COMMENTS:
!       Note the INTENT on the output RTSolution_TL argument is IN OUT rather
!       than just OUT. This is necessary because the argument may be defined
!       upon input. To prevent memory leaks, the IN OUT INTENT is a must.
!
!--------------------------------------------------------------------------------

  FUNCTION CRTM_Compute_RTSolution_TL( &
    Atmosphere   , &  ! FWD Input
    Surface      , &  ! FWD Input
    AtmOptics    , &  ! FWD Input
    SfcOptics    , &  ! FWD Input
    RTSolution   , &  ! FWD Input
    Atmosphere_TL, &  ! TL Input
    Surface_TL   , &  ! TL Input
    AtmOptics_TL , &  ! TL Input
    SfcOptics_TL , &  ! TL Input
    GeometryInfo , &  ! Input
    SensorIndex  , &  ! Input
    ChannelIndex , &  ! Input
    RTSolution_TL, &  ! TL Output
    RTV          ) &  ! Internal variable input
  RESULT( Error_Status )
    ! Arguments
    TYPE(CRTM_Atmosphere_type),   INTENT(IN)     :: Atmosphere
    TYPE(CRTM_Surface_type),      INTENT(IN)     :: Surface
    TYPE(CRTM_AtmOptics_type),    INTENT(IN)     :: AtmOptics
    TYPE(CRTM_SfcOptics_type),    INTENT(IN)     :: SfcOptics
    TYPE(CRTM_RTSolution_type),   INTENT(IN)     :: RTSolution
    TYPE(CRTM_Atmosphere_type),   INTENT(IN)     :: Atmosphere_TL
    TYPE(CRTM_Surface_type),      INTENT(IN)     :: Surface_TL
    TYPE(CRTM_AtmOptics_type),    INTENT(IN)     :: AtmOptics_TL
    TYPE(CRTM_SfcOptics_type),    INTENT(IN OUT) :: SfcOptics_TL
    TYPE(CRTM_GeometryInfo_type), INTENT(IN)     :: GeometryInfo
    INTEGER,                      INTENT(IN)     :: SensorIndex
    INTEGER,                      INTENT(IN)     :: ChannelIndex
    TYPE(CRTM_RTSolution_type),   INTENT(IN OUT) :: RTSolution_TL
    TYPE(RTV_type),               INTENT(IN)     :: RTV
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Compute_RTSolution_TL'
    ! Local variables
    CHARACTER(256) :: Message
    INTEGER :: nZ
    REAL(fp) :: User_Emissivity_TL, Direct_Reflectivity_TL
    REAL(fp)                                     :: Planck_Surface_TL    ! Surface TL radiance
    REAL(fp), DIMENSION( 0:Atmosphere%n_Layers ) :: Planck_Atmosphere_TL ! *LAYER* TL radiances

    ! The following variables are RT model specific
    REAL(fp), DIMENSION( MAX_N_ANGLES, &
                         MAX_N_ANGLES+1, &
                         Atmosphere%n_Layers ) :: Pff_TL ! Forward scattering TL phase matrix
    REAL(fp), DIMENSION( MAX_N_ANGLES, &
                         MAX_N_ANGLES+1, &
                         Atmosphere%n_Layers ) :: Pbb_TL ! Backward scattering TL phase matrix
    REAL(fp), DIMENSION( MAX_N_ANGLES ) :: Scattering_Radiance_TL
    REAL(fp) :: Radiance_TL

    ! ------
    ! Set up
    ! ------
    Error_Status = SUCCESS

    RTSolution_TL%RT_Algorithm_Name = RTSolution%RT_Algorithm_Name

    Error_Status = Assign_Common_Input_TL( Atmosphere             , &  ! FWD Input
                                           Surface                , &  ! FWD Input
                                           AtmOptics              , &  ! FWD Input
                                           SfcOptics              , &  ! FWD Input
                                           Atmosphere_TL          , &  ! TL Input
                                           Surface_TL             , &  ! TL Input
                                           AtmOptics_TL           , &  ! TL Input
                                           SfcOptics_TL           , &  ! TL Input Output
                                           GeometryInfo           , &  ! Input
                                           SensorIndex            , &  ! Input
                                           ChannelIndex           , &  ! Input
                                           RTSolution_TL          , &  ! TL Output
                                           nz                     , &  ! Output
                                           User_Emissivity_TL     , &  ! Output
                                           Direct_Reflectivity_TL , &  ! Output
                                           Planck_Surface_TL      , &  ! Output
                                           Planck_Atmosphere_TL   , &  ! Output
                                           Pff_TL                 , &  ! Output
                                           Pbb_TL                 , &  ! Output
                                           RTV          )   ! Internal variable input
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error assigning input for TL RTSolution algorithms'
      CALL Display_Message( ROUTINE_NAME, TRIM(Message), Error_Status )
      RETURN
    END IF

    ! ---------------------------------------------
    ! Perform the tangent-linear radiative transfer
    ! ---------------------------------------------
    ! Select the RT model
    IF( RTV%Scattering_RT ) THEN

      ! Select the scattering RT model
      SELECT CASE(RTV%RT_Algorithm_Id)

        CASE (RT_ADA)
          ! NESDIS advanced adding-doubling method
          CALL CRTM_ADA_TL( &
                 Atmosphere%n_Layers,                      & ! Input, number of atmospheric layers
                 AtmOptics%Single_Scatter_Albedo,          & ! Input, FWD layer single scattering albedo
                 AtmOptics%Optical_Depth,                  & ! Input, FWD layer optical depth
                 RTV%Cosmic_Background_Radiance,           & ! cosmic background radiation
                 SfcOptics%Emissivity(1:nZ,1),             & ! Input, FWD surface emissivity
                 SfcOptics%Direct_Reflectivity(1:nZ,1),    & ! Input, surface direct reflectivity
                 RTV,                                      & ! Input, structure containing forward results
                 Planck_Atmosphere_TL,                     & ! Input, TL layer radiances
                 Planck_Surface_TL,                        & ! Input, TL surface radiance
                 AtmOptics_TL%Single_Scatter_Albedo,       & ! Input, TL layer single scattering albedo
                 AtmOptics_TL%Optical_Depth,               & ! Input, TL layer optical depth
                 SfcOptics_TL%Emissivity(1:nZ,1),          & ! Input, TL surface emissivity
                 SfcOptics_TL%Reflectivity(1:nZ,1,1:nZ,1), & ! Input, TL surface reflectivity
                 SfcOptics_TL%Direct_Reflectivity(1:nZ,1), & ! Input, TL surface direct reflectivity
                 Pff_TL(1:nZ,1:(nZ+1),:),                  & ! Input, TL layer forward phase matrix
                 Pbb_TL(1:nZ,1:(nZ+1),:),                  & ! Input, TL layer backward phase matrix
                 Scattering_Radiance_TL(1:nZ)              ) ! Output, TL radiances
        CASE (RT_SOI)
          ! UW SOI RT solver
          CALL CRTM_SOI_TL( &
                 Atmosphere%n_Layers,                      & ! Input, number of atmospheric layers
                 AtmOptics%Single_Scatter_Albedo,          & ! Input, FWD layer single scattering albedo
                 AtmOptics%Optical_Depth,                  & ! Input, FWD layer optical depth
                 SfcOptics%Emissivity(1:nZ,1),             & ! Input, FWD surface emissivity
                 SfcOptics%Reflectivity(1:nZ,1,1:nZ,1),    & ! Input, surface reflectivity
                 SfcOptics%Index_Sat_Ang,                  & ! Input, Satellite angle index
                 RTV,                                      & ! Input, structure containing forward results
                 Planck_Atmosphere_TL,                     & ! Input, TL layer radiances
                 Planck_Surface_TL,                        & ! Input, TL surface radiance
                 AtmOptics_TL%Single_Scatter_Albedo,       & ! Input, TL layer single scattering albedo
                 AtmOptics_TL%Optical_Depth,               & ! Input, TL layer optical depth
                 SfcOptics_TL%Emissivity(1:nZ,1),          & ! Input, TL surface emissivity
                 SfcOptics_TL%Reflectivity(1:nZ,1,1:nZ,1), & ! Input, TL surface reflectivity
                 Pff_TL(1:nZ,1:nZ,:),                      & ! Input, TL layer forward phase matrix
                 Pbb_TL(1:nZ,1:nZ,:),                      & ! Input, TL layer backward phase matrix
                 Scattering_Radiance_TL(1:nZ)              ) ! Output, TL radiances
      END SELECT
    ELSE
      ! -----------------
      ! Emission model RT
      ! -----------------
      CALL CRTM_Emission_TL( &
             Atmosphere%n_Layers,                      & ! Input, number of atmospheric layers
             RTV%n_Angles,                             & ! Input, number of discrete zenith angles
             GeometryInfo%Cosine_Sensor_Zenith,        & ! Input, cosine of sensor zenith angle
             RTV%Planck_Atmosphere,                    & ! Input, FWD layer radiances
             RTV%Planck_Surface,                       & ! Input, FWD surface radiance
             SfcOptics%Emissivity(1:nZ,1),             & ! Input, FWD surface emissivity
             SfcOptics%Reflectivity(1:nZ,1,1:nZ,1),    & ! Input, FWD surface reflectivity
             SfcOptics%Direct_Reflectivity(1:nZ,1),    & ! Input, FWD surface reflectivity for a point source
             RTV%Solar_Irradiance,                     & ! Input, Source irradiance at TOA
             RTV%Is_Solar_Channel,                     & ! Input, Source sensitive channel info.
             GeometryInfo%Source_Zenith_Radian,        & ! Input, Source zenith angle
             RTV,                                      & ! Input, internal variables
             AtmOptics_TL%Optical_Depth,               & ! Input, TL layer optical depth
             Planck_Atmosphere_TL,                     & ! Input, TL layer radiances
             Planck_Surface_TL,                        & ! Input, TL surface radiance
             SfcOptics_TL%Emissivity(1:nZ,1),          & ! Input, TL surface emissivity
             SfcOptics_TL%Reflectivity(1:nZ,1,1:nZ,1), & ! Input, TL surface reflectivity
             SfcOptics_TL%Direct_Reflectivity(1:nZ,1), & ! Input, TL surface reflectivity for a point source
             Radiance_TL                               ) ! Output, TL radiances
    END IF

    Error_Status = Assign_Common_Output_TL( SfcOptics             , &
                                            RTSolution            , &
                                            GeometryInfo          , &
                                            Radiance_TL           , &
                                            Scattering_Radiance_TL, &
                                            SensorIndex           , &
                                            ChannelIndex          , &
                                            RTV                   , &
                                            RTSolution_TL           )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error assigning output for TL RTSolution algorithms'
      CALL Display_Message( ROUTINE_NAME, TRIM(Message), Error_Status )
      RETURN
    END IF

  END FUNCTION CRTM_Compute_RTSolution_TL
!--------------------------------------------------------------------------------
!
! NAME:
!       CRTM_Compute_RTSolution_AD
!
! PURPOSE:
!       Function to solve the adjoint radiative transfer equation.
!
! CALLING SEQUENCE:
!      Error_Status = CRTM_Compute_RTSolution_AD( Atmosphere   , &  ! FWD Input
!                                                 Surface      , &  ! FWD Input
!                                                 AtmOptics    , &  ! FWD Input
!                                                 SfcOptics    , &  ! FWD Input
!                                                 RTSolution   , &  ! FWD Input
!                                                 RTSolution_AD, &  ! AD Input
!                                                 GeometryInfo , &  ! Input
!                                                 SensorIndex  , &  ! Input
!                                                 ChannelIndex , &  ! Input
!                                                 Atmosphere_AD, &  ! AD Output
!                                                 Surface_AD   , &  ! AD Output
!                                                 AtmOptics_AD , &  ! AD Output
!                                                 SfcOptics_AD , &  ! AD Output
!                                                 RTV            )  ! Internal variable input
!
! INPUT ARGUMENTS:
!       Atmosphere:     Structure containing the atmospheric state data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_Atmosphere_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       Surface:        Structure containing the surface state data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_Surface_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       AtmOptics:      Structure containing the combined atmospheric
!                       optical properties for gaseous absorption, clouds,
!                       and aerosols.
!                       UNITS:      N/A
!                       TYPE:       CRTM_AtmOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       SfcOptics:      Structure containing the surface optical properties
!                       data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_SfcOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       RTSolution:     Structure containing the solution to the RT equation
!                       for the given inputs.
!                       UNITS:      N/A
!                       TYPE:       CRTM_RTSolution_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
!       RTSolution_AD:  Structure containing the RT solution adjoint inputs.
!                       UNITS:      N/A
!                       TYPE:       CRTM_RTSolution_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!       GeometryInfo:   Structure containing the view geometry data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_GeometryInfo_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)
!
!       RTV:            Structure containing internal forward model variables
!                       required for subsequent tangent-linear or adjoint model
!                       calls. The contents of this structure are NOT accessible
!                       outside of the CRTM_RTSolution module.
!                       UNITS:      N/A
!                       TYPE:       RTV_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       Atmosphere_AD:  Structure containing the adjoint atmospheric
!                       state data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_Atmosphere_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!       Surface_AD:     Structure containing the adjoint surface state data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_Surface_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!       AtmOptics_AD:   Structure containing the adjoint combined atmospheric
!                       optical properties for gaseous absorption, clouds,
!                       and aerosols.
!                       UNITS:      N/A
!                       TYPE:       CRTM_AtmOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!       SfcOptics_AD:   Structure containing the adjoint surface optical
!                       properties data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_SfcOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT( IN OUT)
!
! FUNCTION RESULT:
!       Error_Status:   The return value is an integer defining the error status
!                       The error codes are defined in the Message_Handler module.
!                       If == SUCCESS the computation was sucessful
!                          == FAILURE an unrecoverable error occurred
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
! COMMENTS:
!       Note the INTENT on all of the adjoint arguments (whether input or output)
!       is IN OUT rather than just OUT. This is necessary because the Input
!       adjoint arguments are modified, and the Output adjoint arguments must
!       be defined prior to entry to this routine. So, anytime a structure is
!       to be output, to prevent memory leaks the IN OUT INTENT is a must.
!
!--------------------------------------------------------------------------------

  FUNCTION CRTM_Compute_RTSolution_AD( &
    Atmosphere   , &  ! FWD Input
    Surface      , &  ! FWD Input
    AtmOptics    , &  ! FWD Input
    SfcOptics    , &  ! FWD Input
    RTSolution   , &  ! FWD Input
    RTSolution_AD, &  ! AD Input
    GeometryInfo , &  ! Input
    SensorIndex  , &  ! Input
    ChannelIndex , &  ! Input
    Atmosphere_AD, &  ! AD Output
    Surface_AD   , &  ! AD Output
    AtmOptics_AD , &  ! AD Output
    SfcOptics_AD , &  ! AD Output
    RTV          ) &  ! Internal variable input
  RESULT( Error_Status )
    ! Arguments
    TYPE(CRTM_Atmosphere_type),   INTENT(IN)     :: Atmosphere
    TYPE(CRTM_Surface_type),      INTENT(IN)     :: Surface
    TYPE(CRTM_AtmOptics_type),    INTENT(IN)     :: AtmOptics
    TYPE(CRTM_SfcOptics_type),    INTENT(IN)     :: SfcOptics
    TYPE(CRTM_RTSolution_type),   INTENT(IN)     :: RTSolution
    TYPE(CRTM_RTSolution_type),   INTENT(IN OUT) :: RTSolution_AD
    TYPE(CRTM_GeometryInfo_type), INTENT(IN)     :: GeometryInfo
    INTEGER,                      INTENT(IN)     :: SensorIndex
    INTEGER,                      INTENT(IN)     :: ChannelIndex
    TYPE(CRTM_Atmosphere_type),   INTENT(IN OUT) :: Atmosphere_AD
    TYPE(CRTM_Surface_type),      INTENT(IN OUT) :: Surface_AD
    TYPE(CRTM_AtmOptics_type),    INTENT(IN OUT) :: AtmOptics_AD
    TYPE(CRTM_SfcOptics_type),    INTENT(IN OUT) :: SfcOptics_AD
    TYPE(RTV_type),               INTENT(IN)     :: RTV
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_Compute_RTSolution_AD'
    ! Local variables
    CHARACTER(256) :: Message
    INTEGER :: nz
    REAL(fp)                                     :: Planck_Surface_AD    ! Surface AD radiance
    REAL(fp), DIMENSION( 0:Atmosphere%n_Layers ) :: Planck_Atmosphere_AD ! *LAYER* AD radiances
    REAL(fp) :: User_Emissivity_AD    ! Temporary adjoint variable for SfcOptics calcs.
    ! The following variables are RT model specific
    REAL(fp), DIMENSION( MAX_N_ANGLES, &
                         MAX_N_ANGLES+1, &
                         Atmosphere%n_Layers ) :: Pff_AD ! Forward scattering AD phase matrix
    REAL(fp), DIMENSION( MAX_N_ANGLES, &
                         MAX_N_ANGLES+1, &
                         Atmosphere%n_Layers ) :: Pbb_AD ! Backward scattering AD phase matrix
    REAL (fp),DIMENSION( MAX_N_ANGLES ) :: Scattering_Radiance_AD
    REAL (fp) :: Radiance_AD

    ! -----
    ! Setup
    ! -----
    Error_Status = SUCCESS

    RTSolution_AD%RT_Algorithm_Name = RTSolution%RT_Algorithm_Name

    Error_Status = Assign_Common_Input_AD( SfcOptics            , &  ! FWD Input
                                           RTSolution           , &  ! FWD Input
                                           GeometryInfo         , &  ! Input
                                           SensorIndex          , &  ! Input
                                           ChannelIndex         , &  ! Input
                                           RTSolution_AD        , &  ! AD Output/Input
                                           SfcOptics_AD         , &  ! AD Output
                                           Planck_Surface_AD    , &  ! AD Output
                                           Planck_Atmosphere_AD , &  ! AD Output
                                           Radiance_AD          , &  ! AD Output
                                           nz                   , &  ! Output
                                           RTV                    )  ! Internal variable input
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error assigning input for AD RTSolution algorithms'
      CALL Display_Message( ROUTINE_NAME, TRIM(Message), Error_Status )
      RETURN
    END IF

    ! --------------------------------------
    ! Perform the adjoint radiative transfer
    ! --------------------------------------
    ! Select the RT model
    IF( RTV%Scattering_RT ) THEN

      ! Initialise the input adjoint radiance
      Scattering_Radiance_AD = ZERO
      Scattering_Radiance_AD( SfcOptics%Index_Sat_Ang ) = Radiance_AD
!!      RTSolution_AD%Radiance = ZERO

      ! Select the scattering RT model
      IF ( RTV%RT_Algorithm_Id == RT_ADA ) THEN
        ! NESDIS advanced adding-doubling method
        CALL CRTM_ADA_AD( &
             Atmosphere%n_Layers,                      & ! Input, number of atmospheric layers
             AtmOptics%Single_Scatter_Albedo,          & ! Input, FWD layer single scattering albedo
             AtmOptics%Optical_Depth,                  & ! Input, FWD layer optical depth
             RTV%Cosmic_Background_Radiance,           & ! Input, cosmic background radiation
             SfcOptics%Emissivity(1:nZ,1),             & ! Input, FWD surface emissivity
             SfcOptics%Direct_Reflectivity(1:nZ,1),    & ! Input, FWD surface reflectivity for a point source
             RTV,                                      & ! In/Output, internal variables
             Scattering_Radiance_AD(1:nZ),             & ! Input, AD radiances
             Planck_Atmosphere_AD,                     & ! Output, AD layer radiances
             Planck_Surface_AD,                        & ! Output, AD surface radiance
             AtmOptics_AD%Single_Scatter_Albedo,       & ! Output, AD layer single scattering albedo
             AtmOptics_AD%Optical_Depth,               & ! Output, AD layer optical depth
             SfcOptics_AD%Emissivity(1:nZ,1),          & ! Output, AD surface emissivity
             SfcOptics_AD%Reflectivity(1:nZ,1,1:nZ,1), & ! Output, AD surface reflectivity
             SfcOptics_AD%Direct_Reflectivity(1:nZ,1), & ! Output, AD surface reflectivity for a point source
             Pff_AD(1:nZ,1:(nZ+1),:),                  & ! Output, AD layer forward phase matrix
             Pbb_AD(1:nZ,1:(nZ+1),:)                   ) ! Output, AD layer backward phase matrix
      ELSE
        ! UW SOI RT solver
        CALL CRTM_SOI_AD( &
             Atmosphere%n_Layers,                      & ! Input, number of atmospheric layers
             AtmOptics%Single_Scatter_Albedo,          & ! Input, FWD layer single scattering albedo
             AtmOptics%Optical_Depth,                  & ! Input, FWD layer optical depth
             SfcOptics%Emissivity(1:nZ,1),             & ! Input, FWD surface emissivity
             SfcOptics%Reflectivity(1:nZ,1,1:nZ,1),    & ! Input, FWD surface reflectivity
             SfcOptics%Index_Sat_Ang,                  & ! Input, Satellite angle index
             RTV,                                      & ! In/Output, internal variables
             Scattering_Radiance_AD(1:nZ),             & ! Input, AD radiances
             Planck_Atmosphere_AD,                     & ! Output AD atmospheric layer Planck radiance
             Planck_Surface_AD,                        & ! Output AD surface Planck radiance
             AtmOptics_AD%Single_Scatter_Albedo,       & ! Output, AD layer single scattering albedo
             AtmOptics_AD%Optical_Depth,               & ! Output, AD layer optical depth
             SfcOptics_AD%Emissivity(1:nZ,1),          & ! Output, AD surface emissivity
             SfcOptics_AD%Reflectivity(1:nZ,1,1:nZ,1), & ! Output, AD surface reflectivity
             Pff_AD(1:nZ,1:(nZ+1),:),                  & ! Output, AD layer forward phase matrix
             Pbb_AD(1:nZ,1:(nZ+1),:)                   ) ! Output, AD layer backward phase matrix

      END IF

    ELSE

      ! -----------------
      ! Emission model RT
      ! -----------------
      CALL CRTM_Emission_AD( &
             Atmosphere%n_Layers,                      & ! Input, number of atmospheric layers
             RTV%n_Angles,                             & ! Input, number of discrete zenith angles
             GeometryInfo%Cosine_Sensor_Zenith,        & ! Input, cosine of sensor zenith angle
             RTV%Planck_Atmosphere,                    & ! Input, FWD layer radiances
             RTV%Planck_Surface,                       & ! Input, FWD surface radiance
             SfcOptics%Emissivity(1:nZ,1),             & ! Input, FWD surface emissivity
             SfcOptics%Reflectivity(1:nZ,1,1:nZ,1),    & ! Input, FWD surface reflectivity
             SfcOptics%Direct_Reflectivity(1:nZ,1),    & ! Input, FWD surface reflectivity for a point source
             RTV%Solar_Irradiance,                     & ! Input, Source irradiance at TOA
             RTV%Is_Solar_Channel,                     & ! Input, Source sensitive channel info.
             GeometryInfo%Source_Zenith_Radian,        & ! Input, Source zenith angle
             RTV,                                      & ! Input, internal variables
             Radiance_AD,                              & ! Input, AD radiance
             AtmOptics_AD%Optical_Depth,               & ! Output, AD layer optical depth
             Planck_Atmosphere_AD,                     & ! Output, AD layer radiances
             Planck_Surface_AD,                        & ! Output, AD surface radiance
             SfcOptics_AD%Emissivity(1:nZ,1),          & ! Output, AD surface emissivity
             SfcOptics_AD%Reflectivity(1:nZ,1,1:nZ,1), & ! Output, AD surface reflectivity
             SfcOptics_AD%Direct_Reflectivity(1:nZ,1)  ) ! Output, AD surface reflectivity for a point source
    END IF

    Error_Status = Assign_Common_Output_AD( Atmosphere           , & ! Input
                                            Surface              , & ! Input
                                            AtmOptics            , & ! Input
                                            SfcOptics            , & ! Input
                                            Pff_AD               , & ! Input
                                            Pbb_AD               , & ! Input
                                            GeometryInfo         , & ! Input
                                            SensorIndex          , & ! Input
                                            ChannelIndex         , & ! Input
                                            nZ                   , & ! Input
                                            AtmOptics_AD         , & ! Output
                                            SfcOptics_AD         , & ! Output
                                            Planck_Surface_AD    , & ! Output
                                            Planck_Atmosphere_AD , & ! Output
                                            User_Emissivity_AD   , & ! Output
                                            Atmosphere_AD        , & ! Output
                                            Surface_AD           , & ! Output
                                            RTSolution_AD        , & ! Output
                                            RTV                  )   ! Input
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error assigning output for AD RTSolution algorithms'
      CALL Display_Message( ROUTINE_NAME, TRIM(Message), Error_Status )
      RETURN
    END IF

  END FUNCTION CRTM_Compute_RTSolution_AD

!--------------------------------------------------------------------------------
!
! NAME:
!       CRTM_Compute_n_Streams
!
! PURPOSE:
!       Function to compute the number of streams required for subsequent
!       radiative transfer calculations
!
! CALLING SEQUENCE:
!       nStreams = CRTM_Compute_n_Streams( Atmosphere,   &  ! Input
!                                          SensorIndex,  &  ! Input
!                                          ChannelIndex, &  ! Input
!                                          RTSolution    )  ! Output
!
! INPUT ARGUMENTS:
!       Atmosphere:     Structure containing the atmospheric state data.
!                       UNITS:      N/A
!                       TYPE:       CRTM_Atmosphere_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)
!
! OUTPUT ARGUMENTS:
!       RTSolution:     Structure containing the scattering flag to be set
!                       for the RT calcs.
!                       UNITS:      N/A
!                       TYPE:       CRTM_RTSolution_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
! FUNCTION RESULT:
!       nStreams:       The number of RT streams required to perform radiative
!                       transfer in a scattering atmosphere.
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Scalar
!
!--------------------------------------------------------------------------------

  FUNCTION CRTM_Compute_nStreams( &
    Atmosphere  , &  ! Input
    SensorIndex , &  ! Input
    ChannelIndex, &  ! Input
    RTSolution  ) &  ! Output
  RESULT( nStreams )
    ! Arguments
    TYPE(CRTM_Atmosphere_type), INTENT(IN)     :: Atmosphere
    INTEGER,                    INTENT(IN)     :: SensorIndex
    INTEGER,                    INTENT(IN)     :: ChannelIndex
    TYPE(CRTM_RTSolution_type), INTENT(IN OUT) :: RTSolution
    ! Function result
    INTEGER :: nStreams
    ! Local variables
    REAL(fp) :: maxReff, Reff, MieParameter
    INTEGER :: n

    ! Set up
    nStreams = 0
    RTSolution%n_full_Streams = nStreams
    RTSolution%Scattering_FLAG = .FALSE.

    ! If no clouds and no aerosols, no scattering, so return
    IF ( Atmosphere%n_Clouds   == 0 .AND. &
         Atmosphere%n_Aerosols == 0       ) RETURN

    ! Determine the maximum cloud particle size
    maxReff = ZERO
    DO n = 1, Atmosphere%n_Clouds
      Reff = MAXVAL(Atmosphere%Cloud(n)%Effective_Radius)
      IF( Reff > maxReff) maxReff = Reff
    END DO
    DO n = 1, Atmosphere%n_Aerosols
      Reff = MAXVAL(Atmosphere%Aerosol(n)%Effective_Radius)
      IF( Reff > maxReff) maxReff = Reff
    END DO

    ! Compute the Mie parameter, 2.pi.Reff/lambda
    MieParameter = TWO * PI * maxReff * SC(SensorIndex)%Wavenumber(ChannelIndex)/10000.0_fp

    ! Determine the number of streams based on Mie parameter
    IF ( MieParameter < 0.01_fp ) THEN
      nStreams = 2
    ELSE IF( MieParameter < ONE ) THEN
      nStreams = 4
    ELSE
      nStreams = 6
    END IF

! Hardcode number of streams for testing purposes
!    nStreams = 6

    ! Set RTSolution scattering info
    RTSolution%Scattering_Flag = .TRUE.
    RTSolution%n_full_Streams  = nStreams + 2

  END FUNCTION CRTM_Compute_nStreams

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_RTSolution_Version
!
! PURPOSE:
!       Subroutine to return the module version information.
!
! CALLING SEQUENCE:
!       CALL CRTM_RTSolution_Version( Id )
!
! OUTPUT ARGUMENTS:
!       Id:            Character string containing the version Id information
!                      for the module.
!                      UNITS:      N/A
!                      TYPE:       CHARACTER(*)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE CRTM_RTSolution_Version( Id )
    CHARACTER(*), INTENT(OUT) :: Id
    Id = MODULE_VERSION_ID
  END SUBROUTINE CRTM_RTSolution_Version

END MODULE CRTM_RTSolution


	subroutine find_events(numb,srate,arry)
c
c I hope this will be for use with both Full-frequency and High Pass filtered
c signals (eg measured with non-DC mike).
c                                                BMS Sep 7 1993
c Increase noinfl (again) - the possible size of the input file - July 16 2002
c
        real arry(*)
c
c pity idelay_used is in this common block, but so it goes
        logical linv_used
        character*80 inv_name, orig_name
        character*8 ntime
        character*9 ndate
        common /footer/ linv_used, inv_name, orig_name, srate_inv_used,
     $             idelay_used, ntime, ndate
c
c pass in common the NINFL time and pressure pairs used to define this wave
        parameter (noinflp = 10000)
        real*4 press(noinflp), atime(noinflp)
        common /boomcom/ press,atime,ninfl,srate_boom
c
c let's have a new common block for the variables we define here
        parameter (max_events = 50)
	common /def_events/ num_events,ievents(max_events),
     $         itype_events(max_events),
     $         istart_events(max_events),iend_events(max_events)
c

c initialize
	num_events = 0
	do i=1,max_events
	   ievents(i) = 0
	   itype_events(i) = 0
	   istart_events(i) = 0
	   iend_events(i) = 0
	enddo

c the boom is defined in press and atime arrays, but the times in atime
c are offset from the time history in arry by float(idelay_used)/srate
c or, in index terms, by :-

	iuse_delay = idelay_used
c	iuse_delay = min(512,idelay_used)

c start is a zero crossing (or should be)
	num_events = 1
	ievents(num_events) = 1
c type 0 = zerocrossing
c type 1 = +ve peak (ie ends above zero)
c type -1 = -ve peak (ie starts below zero)
c (what if both? then below zero end is -99 and above is +99)
c (which doesn't make any sense!!! So treat it with care!)
	itype_events(num_events) = 0
	do i=2,ninfl-1
	   if ( press(i) .gt. press(i-1) ) then
c we have an peak-type event - herein defined as any +ve pressure change;
c WON'T WORK FOR KNEES (or maybe it will - just depends on the point of view)
	      if (press(i-1) .lt. 0.0 .and. press(i) .gt. 0.0) then
c curses! Two events?  Who cares about zero crossings really? Jack does!
c (the other way doesn't matter 'cos the only events that count are +ve going!)
	         num_events = num_events+1
	         if (num_events .gt. max_events) then
	            print *,'We have exceeded the array
     $ size for storing events'
	            go to 1000
	         endif
c index into arry of that nominal event time is
                 ievents(num_events) =
     $                     indextime(atime(i-1),srate,numb,iuse_delay)
                 itype_events(num_events) = -99
                 num_events = num_events+1
                 ievents(num_events) =
     $                     indextime(atime(i),srate,numb,iuse_delay)
                 itype_events(num_events) = 99
c skip the zero crossing tests - keep it one event
	         go to 910
	      else if (abs(press(i)) .gt. abs(press(i-1))) then
	         num_events = num_events+1
                 ievents(num_events) =
     $                     indextime(atime(i),srate,numb,iuse_delay)
                 itype_events(num_events) = 1
	      else
	         num_events = num_events+1
                 ievents(num_events) =
     $                     indextime(atime(i-1),srate,numb,iuse_delay)
                 itype_events(num_events) = -1
	      endif
	   endif

c a zero crossing may happen between events (nowhere else?)
	   if (press(i) .eq. 0.0) then
c only accept this as a zero crossing if we go from above zero to below zero
c or vice versa.  Is that an adequate definition?
	      if ((press(i+1) .gt. 0.0 .and. press(i-1) .lt. 0.0) .or.
     $	          (press(i-1) .gt. 0.0 .and. press(i+1) .lt. 0.0)) then
	         num_events = num_events+1
	         ievents(num_events) =
     $                     indextime(atime(i),srate,numb,iuse_delay)
	         itype_events(num_events) = 0
	      endif
	   else if (press(i-1) .gt. 0.0 .and. press(i) .lt. 0.0) then
	      jend = indextime(atime(i),srate,numb,iuse_delay)
	      jstart = indextime(atime(i-1),srate,numb,iuse_delay)
c stop at the point before (in time) the zero crossing, if you can't stop
c right on it
	      do j=jstart,jend-1
	         if ( (arry(j) .ge. 0.0) .and.
     $                            (arry(j+1) .lt. 0.0) ) then
	            num_events = num_events+1
	            ievents(num_events) = j
	            itype_events(num_events) = 0
	            go to 900
	         endif
	      enddo
 900	      continue

	   else if (press(i-1) .lt. 0.0 .and. press(i) .gt. 0.0) then
	      jend = indextime(atime(i),srate,numb,iuse_delay)
	      jstart = indextime(atime(i-1),srate,numb,iuse_delay)
c stop at the point before (in time) the zero crossing, if you can't stop
c right on it
	      do j=jstart,jend-1
	         if ( (arry(j) .le. 0.0) .and.
     $                            (arry(j+1) .gt. 0.0) ) then
	            num_events = num_events+1
	            ievents(num_events) = j
	            itype_events(num_events) = 0
	            go to 905
	         endif
	      enddo
 905	      continue
	   endif
 910	   continue
	enddo
c may be an event at the end (but not a zero CROSSING)
	i = ninfl
	if ( press(i) .gt. press(i-1) ) then
c we have an peak-type event - herein defined as any +ve pressure change;
c WON'T WORK FOR KNEES (or maybe it will - just depends on the point of view)
	   if (abs(press(i)) .gt. abs(press(i-1))) then
	      num_events = num_events+1
              ievents(num_events) =
     $                     indextime(atime(i),srate,numb,iuse_delay)
              itype_events(num_events) = 1
	   else
	      num_events = num_events+1
              ievents(num_events) =
     $                     indextime(atime(i-1),srate,numb,iuse_delay)
              itype_events(num_events) = -1
	   endif
	endif
c and add the end point (which IS a zero crossing within the meaning of the act)
	num_events = num_events + 1
	ievents(num_events) = numb
	itype_events(num_events) = 0

c is that it?  No, let's define the start and end of each event while we're here
c
c       Z1     E1     E2   Z2       Z3
c        |      |      |   |        |
c        |     / \    / \  |        |
c        |    /   \  /   \ |        |
c        -----     \/     \|    -----
c                          \   /
c                           \ /
c                            |
c                            |
c                           E3
c
c  E1 goes from Z1 to min. between E1 and E2
c  E2 goes from min. between E1 and E2 to Z2
c  E3 goes from Z2 to Z3 (that's the easy one)
c
 1000	do now_event=1,num_events
c is this a peak (type <> 0)?
	   if (itype_events(now_event) .ne. 0) then
c If there are two events between zero-crossing points, we need to
c separate them and use the minimum (maximum) between them as the start/end
c of the event.  Otherwise we can use the zero crossing times (indeces).
	      if (itype_events(now_event-1) .eq. 0) then
	         istart_events(now_event) = ievents(now_event-1)
	      else if (itype_events(now_event-1) .eq.
     $                        itype_events(now_event)) then
	         if (itype_events(now_event) .eq. 1) then
	            num_to_use = ievents(now_event) - ievents(now_event-1)
        	    minmiddle = bmin(arry(ievents(now_event-1)),
     $                     1+num_to_use,indexminmiddle)
	            indexminmiddle=indexminmiddle+ievents(now_event-1)-1
	         else
	            num_to_use = ievents(now_event) - ievents(now_event-1)
        	    minmiddle = bmax(arry(ievents(now_event-1)),
     $                     1+num_to_use,indexminmiddle)
	            indexminmiddle=indexminmiddle+ievents(now_event-1)-1
	         endif
	         istart_events(now_event) = indexminmiddle
	      else
c what else could there be?  Apart from 99's - then what do I do?
	         print *,'Help #1 in find_events'
	         istart_events(now_event) = 1
	      endif

	      if (itype_events(now_event+1) .eq. 0) then
	         iend_events(now_event) = ievents(now_event+1)
	      else if (itype_events(now_event+1) .eq.
     $                        itype_events(now_event)) then
	         if (itype_events(now_event) .eq. 1) then
	            num_to_use = ievents(now_event+1) - ievents(now_event)
        	    minmiddle = bmin(arry(ievents(now_event)),
     $                     1+num_to_use,indexminmiddle)
	            indexminmiddle=indexminmiddle+ievents(now_event)-1
	         else
	            num_to_use = ievents(now_event+1) - ievents(now_event)
        	    minmiddle = bmax(arry(ievents(now_event)),
     $                     1+num_to_use,indexminmiddle)
	            indexminmiddle=indexminmiddle+ievents(now_event)-1
	         endif
	         iend_events(now_event) = indexminmiddle
	      else
c what else could there be?  Apart from 99's - then what do I do?
	         print *,'Help #2 in find_events'
	         iend_events(now_event) = numb
	      endif
	   endif
	enddo
c
	print *,num_events,' events'
	do i=1,num_events
	   print *,ievents(i),itype_events(i),
     $            istart_events(i),iend_events(i),arry(ievents(i))
	enddo

	return
	end


	subroutine makefile(ch)
c
C	A PROGRAM TO SEARCH FOR LANGMUIR WAVES IN THE SOLAR WIND IN TDSF.
C		OR FILL
c
C	TEMPORARILY, FINDS BIG TYPE III LANGMUIR WAVES
C
C	TO EXCLUDE UPSTREAM WAVES, USE PERIODS WHEN WIND IS MORE THAN
C		100 RE UPSTREAM
C		1996 MAY 19 TO AUG 12   =   5252  to  5336
C		1997 JAN 12 TO JUL 4    =   5490  to  5663
C		1997 NOV 2  TO FEB 20   =   5784  to  5893
C	INSIDE TIMES:
C		2000 APR 21 TO AUG 23 APPROX, PETAL ORBITS
C
C	OR, IF CLOSER, WHEN NO CONNECTION TO BOW SHOCK  (NOT DONE YET)
C
	integer*4 ch,ok,okt,OK1,OK2,SCETI4(2),N1DATA(2048),N2DATA(2048)
	INTEGER*4 W_CHANNEL_CLOSE,W_EVENT,RET_SIZE,W_MESSAGES_OFF
	INTEGER*4 W_ITEM_I4,W_ITEM_R4,W_ITEM_R8
	INTEGER*4 TDS_CHANNEL,ISRC,SUNCLOCK
	REAL*8 SCET8,XGSE,YGSE,ZGSE,RGSE
	REAL DBSPEC1(1025),V1DATA(2048)
	REAL DBSPEC2(1025),V2DATA(2048)
	REAL ZCROSS(1024),Z1INT(1024),Z2INT(1024)
	REAL FREQ(1024),FCOUNT(2),FAVR(2),FSTD(2),F3MOM(2),FBW(2),SKEW(2)
	character*32 ITEM
	character*4 event
	DATA TWOPI /6.2831853/
	DATA YXRATIO /11.8/
C	ABOVE BASED ON LEFFX = 41.1, LEFFY = 3.79
	DATA PXTOT,PYTOT /0.,0./
C	data event /'TDSF'/
	data event /'FILL'/
C
	YXSQ = YXRATIO**2
	IFOUND = 0
 100	ok = w_event(ch,event)
C
C	CHECK FOR END OF RECORD
C
	if (ok.ne.1) then
		if(ok.eq.82) then
		   ok = w_channel_close(ch)
		   PRATIO = 0.
	 	   IF(PYTOT.NE.0.) PRATIO = PXTOT/PYTOT
		   WRITE(69,*) SCETI4(1),PXTOT,PYTOT,PRATIO
		   return
	        endif
		write(6,*) 'cannot open ',event, ', ok=', ok
	endif
C
C	END OF END OF RECORD CHECK
C
	OKT = W_MESSAGES_OFF(ch)
C
C
	ITEM = 'CHANNEL'
	ok = W_ITEM_I4(ch, item, TDS_CHANNEL, 1, ret_size)
C	ITEM = 'CAL_PA'
C	ok = W_ITEM_I4(ch, item, ICAL, 1, ret_size)
C	IF(ICAL.NE.0) GO TO 100
C
	IPROS = 2
	IF(TDS_CHANNEL.EQ.1) THEN
C	  ITEM = 'DATA'
C	  ok1 = W_ITEM_I4(ch, item, N1DATA, 2048, ret_size)
	  CALL TDS_PHYS(CH,IPROS,N1DATA,V1DATA,DBSPEC1)
	  ITEM = 'EVENT_NUMBER'
	  ok = W_ITEM_I4(ch, item, NO_EVT1, 1, ret_size)
		MAXCH1 = 0
		DO N = 1,2048
		  MAXCH1 = MAX0(MAXCH1,IABS(N1DATA(N)-128))
		ENDDO
	  GO TO 100
	ELSEIF(TDS_CHANNEL.EQ.2) THEN
C	  ITEM = 'DATA'
C	  ok2 = W_ITEM_I4(ch, item, N2DATA, 2048, ret_size)
	  CALL TDS_PHYS(CH,IPROS,N2DATA,V2DATA,DBSPEC2)
	  ITEM = 'EVENT_NUMBER'
	  ok = W_ITEM_I4(ch, item, NO_EVT, 1, ret_size)
	  IF(NO_EVT.NE.NO_EVT1) GO TO 100
		MAXCH2 = 0
		DO N = 1,2048
		  MAXCH2 = MAX0(MAXCH2,IABS(N2DATA(N)-128))
		ENDDO
	ELSE
	  GO TO 100
	ENDIF
C*****
	IF(MAXCH1.LT.107.AND.MAXCH2.LT.90) GO TO 100
C*****

C
CDIAG	PRINT*,'******START EVENT',NO_EVT1,NO_EVT,' *****'
C
C	MOST OF THE EVENTS ARE BLOBS.  TO ELIMINATE THEM:
C	BLOBS START NEAR THE MIDDLE, AND MOSTLY OCCUPY THE
C	SECOND HALF OF AN EVENT.  SO REQUIRE THAT THE MAXIMUM
C	INTERVAL BETWEEN ZEROS IN THE SECOND HALF NOT BE
C	MORE THAN ?? TIMES THE AVERAGE INTERVAL IN THE FIRST
C	HALF
C
C	THERE ARE ALSO SPIKES.  TO ELIMINATE THEM, CALCULATE THE
C	NUMBER OF POINTS WHICH ARE LARGER THAN HALF THE PEAK.
C
	IF(TDS_CHANNEL.EQ.1) GO TO 100		! GO GET CHANNEL 2
	IF(TDS_CHANNEL.NE.2) GO TO 100
C
	ITEM = 'WIND_ORBIT_X(GSE)_R8'
	ok = W_ITEM_R8(ch, item, XGSE, 1, ret_size)
	ITEM = 'WIND_ORBIT_Y(GSE)_R8'
	ok = W_ITEM_R8(ch, item, YGSE, 1, ret_size)
	ITEM = 'WIND_ORBIT_Z(GSE)_R8'
	ok = W_ITEM_R8(ch, item, ZGSE, 1, ret_size)
	RGSE = DSQRT(XGSE**2+YGSE**2+ZGSE**2)
C
	IF(RGSE.LT.6.4D05) THEN			! LIMIT 100 RE
C	    ADVANCE BY ONE HOUR AND GET ANOTHER EVENT
C	    ITEM = 'EVENT_SCET_R8'
C	    OK = W_ITEM_R8(ch, item, SCET8, 1, ret_size)
	    ITEM = 'EVENT_SCET'
	    ok = W_ITEM_I4(ch, item, SCETI4, 2, ret_size)
	    PRINT*,RGSE/6.38E3,'INSIDE 100 RE',SCETI4
C	    SCET8 = SCET8 + 1.D00/24.D00
C	    CALL W_CHANNEL_POSITION(CH,SCET8)
C	    GO TO 100
	  ENDIF

C
	XMAX = 0.
	YMAX = 0.
	XMIN = 0.
	YMIN = 0.
	DO N = 1,2048
	  XMAX = AMAX1(XMAX,V1DATA(N))
	  YMAX = AMAX1(YMAX,V2DATA(N))
	  XMIN = AMIN1(XMIN,V1DATA(N))
	  YMIN = AMIN1(YMIN,V2DATA(N))
	ENDDO
	CRIT = .5
C****
	XMAX = AMAX1(XMAX,-XMIN)
	YMAX = AMAX1(YMAX,-YMIN)
C****
	XMAX = CRIT*XMAX
	YMAX = CRIT*YMAX
	XCOUNT = 0.
	YCOUNT = 0.
	DO N = 1,2048
	  IF(ABS(V1DATA(N)).GT.XMAX) XCOUNT = XCOUNT + 1.
	  IF(ABS(V2DATA(N)).GT.YMAX) YCOUNT = YCOUNT + 1.
	ENDDO
C
	DO N = 1,2048
	  N1DATA(N) = N1DATA(N) - 128
	  N2DATA(N) = N2DATA(N) - 128
	ENDDO
C
C	FIND ZERO CROSSINGS
C
	IZCNT = 1
	ZCROSS(IZCNT) = 0.
	IL = 1
	IZ = IL
C	  IF(N1DATA(IL).EQ.0) PRINT*,'ZERO DATA',IL,N1DATA(IL),N1DATA(IL+1)
C
C	FIRST HALF OF CHANNEL 1
C
	DO IL = 1,1023
C
C	    IF(N1DATA(IL).EQ.0) PRINT*,'ZERO DATA',IL,N1DATA(IL-1),
C     1     N1DATA(IL),N1DATA(IL+1)
C
C		COUNT ONLY POS TO NEG
C
	    IF(N1DATA(IL).GT.0.AND.N1DATA(IL+1).LE.0) THEN
	        IZCNT = IZCNT+1
		S1 = N1DATA(IL)
		S2 = N1DATA(IL+1)
		IF(S1-S2.NE.0.) THEN
	  	   ZCROSS(IZCNT) = IL + S1/(S1-S2)
	  	ELSE
		   ZCROSS(IZCNT) = IL
		ENDIF
	    ENDIF
	ENDDO
C
	ZCNT1 = IZCNT
C
	AVR1_1ST_HALF = 1023./ZCNT1
	NZCNT1 = IZCNT
C
	Z1MAX = 0.
	DO N = 1,IZCNT-1
	  Z1INT(N) = ZCROSS(N+1) - ZCROSS(N)
	  Z1MAX = AMAX1(Z1INT(N),Z1MAX)
C	  IF(Z1INT(N).EQ.0.) PRINT*,'ZINT=0 AT ',N
	  IF(Z1INT(N).EQ.0.) Z1INT(N) = 1.E-6
	ENDDO
C
C	SECOND HALF OF CHANNEL 1
C
	DO IL = 1024,2047
C
C		COUNT ONLY POS TO NEG
C
	    IF(N1DATA(IL).GT.0.AND.N1DATA(IL+1).LE.0) THEN
	        IZCNT = IZCNT+1
		S1 = N1DATA(IL)
		S2 = N1DATA(IL+1)
		IF(S1-S2.NE.0.) THEN
	  	   ZCROSS(IZCNT) = IL + S1/(S1-S2)
	  	ELSE
		   ZCROSS(IZCNT) = IL
		ENDIF
	    ENDIF
	ENDDO
	IZCNT = IZCNT + 1
	ZCROSS(IZCNT) = 2048.
C
	AVR1_2ND_HALF = 1023./(IZCNT-NZCNT1)
C
	Z1MAX = 0.
	DO N = NZCNT1,IZCNT-1
	  Z1INT(N) = ZCROSS(N+1) - ZCROSS(N)
	  if(z1int(n).gt.z1max) then
	     z1max = z1int(n)
	     nnmax = n
	  endif
C	  IF(Z1INT(N).EQ.0.) PRINT*,'ZINT=0 AT ',N
	  IF(Z1INT(N).EQ.0.) Z1INT(N) = 1.E-6
	ENDDO
CDIAG	print*,'max int ch 1',z1max,' at',zcross(nnmax),zcross(nnmax+1)
C
C	NOW AVR1_1ST_HALF IS THE AVERAGE INTERVAL, IN NUMBER OF SAMPLES
C	IN THE FIRST HALF OF THE EVENT, AND Z1MAX IS THE MAXIMUM
C	INTERVAL IN THE SECOND HALF.  Z1MAX IS EXPECTED TO BE LARGE
C	FOR BLOBS
C
CDAIG	print*,'zero crossings, ch 1,AVR1_1ST_HALF,Z1MAX',NO_EVT,izcnt,
CDIAG     1		AVR1_1ST_HALF,Z1MAX
	IF(Z1MAX.GT.5.*AVR1_1ST_HALF.AND.Z1MAX.GT.220.) THEN
C	  PRINT*,NO_EVT,'  CH 1 BLOB',AVR1_1ST_HALF,Z1MAX
C	  ITEM = 'SUN_ANGLE'
C	  ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
C	  write(51,*) no_evt,avr1_1st_half,z1max,sunclock
	  IFOUND = 0
	  GO TO 100
	ENDIF
C
	ZCNT1 = IZCNT

C
C	FIRST HALF OF CHANNEL 2
C
	IZCNT = 1
	ZCROSS(IZCNT) = 1.
C
	DO IL = 1,1023
C
C		COUNT ONLY POS TO NEG
C
	  IF(N2DATA(IL).GT.0.AND.N2DATA(IL+1).LE.0) THEN
	        IZCNT = IZCNT+1
		S1 = N2DATA(IL)
		S2 = N2DATA(IL+1)
		IF(S1-S2.NE.0.) THEN
	  	   ZCROSS(IZCNT) = IL + S1/(S1-S2)
	  	ELSE
		   ZCROSS(IZCNT) = IL
		ENDIF
	  ENDIF
	ENDDO
C
	AVR2_1ST_HALF = 1023./IZCNT
	NZCNT2 = IZCNT
C
C	SECOND HALF OF CHANNEL 2
C
	DO IL = 1025,2047
C
C		COUNT ONLY POS TO NEG
C
	  IF(N2DATA(IL).GT.0.AND.N2DATA(IL+1).LE.0) THEN
	        IZCNT = IZCNT+1
		S1 = N2DATA(IL)
		S2 = N2DATA(IL+1)
		IF(S1-S2.NE.0.) THEN
	  	   ZCROSS(IZCNT) = IL + S1/(S1-S2)
	  	ELSE
		   ZCROSS(IZCNT) = IL
		ENDIF
	  ENDIF
	ENDDO
	IZCNT = IZCNT + 1
	ZCROSS(IZCNT) = 2048.
C
	Z2MAX = 0.
	DO N = NZCNT2,IZCNT-1
	  Z2INT(N) = ZCROSS(N+1) - ZCROSS(N)
c	  Z2MAX = AMAX1(Z2INT(N),Z2MAX)
	  if(z2int(n).gt.z2max) then
	     z2max = z2int(n)
	     nnmax = n
	  endif
C	  IF(Z2INT(N).EQ.0.) PRINT*,'ZINT=0 AT ',N
	  IF(Z2INT(N).EQ.0.) Z2INT(N) = 1.E-6
	ENDDO
C	print*,'max int ch 2',z2max,' at',zcross(nnmax),zcross(nnmax+1)
CDIAG	print*,'zero crossings, ch 2,AVR2_1ST_HALF,Z2MAX',NO_EVT,izcnt,
CDIAG     1		AVR2_1ST_HALF,Z2MAX
	IF(Z2MAX.GT.5.*AVR2_1ST_HALF.AND.Z2MAX.GT.220.) THEN
C	  PRINT*,NO_EVT,' CH 2 BLOB',AVR2_1ST_HALF,Z2MAX
C	  ITEM = 'SUN_ANGLE'
C	  ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
C	  write(52,*) no_evt,avr2_1st_half,z2max,sunclock
	  IFOUND = 0
	  GO TO 100
	ENDIF
C
	ZCNT2 = IZCNT
C
C	I FOUND THAT THERE ARE BLOBS AT RANDOM IN CHANNEL 2, PRESUMABLE
C	BECAUSE THE TRIGGER, FROM CHANNEL 1, SOMETIMES CATCHES
C	ONE AT RANDOM.  SO TEST FOR THESE
C
	AVR2_ALL = 2047./IZCNT
	Z3MAX = 0.
	DO N = 1,IZCNT-1
	  Z2INT(N) = ZCROSS(N+1) - ZCROSS(N)
	  if(z2int(n).gt.z3max) then
	     z3max = z2int(n)
	     nnmax = n
	  endif
	ENDDO
c	PRINT*,'TEST 3',NO_EVT,AVR2_ALL,Z3MAX,NNMAX
C
	IF(Z3MAX.GT.5.*AVR2_ALL.OR.Z3MAX.GT.220.) THEN
C	  PRINT*,NO_EVT,' CH 2 RANDOM BLOB',AVR2_1ST_HALF,Z3MAX
C	  ITEM = 'SUN_ANGLE'
C	  ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
C	  write(53,*) no_evt,avr2_all,z3max,sunclock,nnmax
	  IFOUND = 0
	  GO TO 100
	ENDIF
C
	ITEM = 'SOURCE'
	ok = W_ITEM_I4(ch, item, ISRC, 1, ret_size)
	ITEM = 'EVENT_NUMBER'
	ok = W_ITEM_I4(ch, item, NO_EVT, 1, ret_size)
	ITEM = 'EVENT_SCET'
	ok = W_ITEM_I4(ch, item, SCETI4, 2, ret_size)
	ITEM = 'FAST_RX_SPEED_R4'
	ok = W_ITEM_R4(ch, item, SPS, 1, ret_size)
C	ITEM = 'WIND_MFI_BPHI(GSE)_R4'
C	ok = W_ITEM_R4(ch, item, AZMAG, 1, ret_size)
C	ITEM = 'MAG_ELEVATION'
C	ok = W_ITEM_I4(ch, item, MAGEL, 1, ret_size)
C	ITEM = 'SUN_ANGLE'
C	ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
C	ITEM = 'WIND_3DP_E_TEMP_R4'
C	ok = W_ITEM_R4(ch, item, TEMPE, 1, ret_size)
C	ITEM = 'WIND_3DP_ION_TEMP_R4'
C	ok = W_ITEM_R4(ch, item, TEMPI, 1, ret_size)
	ITEM = 'WIND_3DP_ION_DENSITY_R4'
	ok = W_ITEM_R4(ch, item, DENS, 1, ret_size)
C	ITEM = 'WIND_3DP_ION_VX(GSE)_R4'
C	ok = W_ITEM_R4(ch, item, VX, 1, ret_size)
C	ITEM = 'WIND_3DP_ION_VY(GSE)_R4'
C	ok = W_ITEM_R4(ch, item, VY, 1, ret_size)
C	ITEM = 'WIND_MFI_BMAG_R4'
C	ok = W_ITEM_R4(ch, item, BMAG, 1, ret_size)
C	ITEM = 'WIND_SPIN_RATE_R4'
C	ok = W_ITEM_R4(ch, item, SPINRATE, 1, ret_size)
C	if(ok.ne.1) then
	  spinrate = 2.
C	endif
C
C	CALCULATE FREQUENCIES FOR SPECTRUM
C
	DO N = 1,1024
	  FREQ(N) = (N-1)*SPS/2048.    ! FREQ(N) GOES WITH DBSPECT(N)
	ENDDO
C
C	CALCULATE BANDWIDTH, ETC.
C
	FLLIM = 4
	FUPLIM = 205			! 12 KHZ AT 120 KSPS
C	PRINT*,'DO FREQS',FREQ(FLLIM),FREQ(FUPLIM)
	DO NC = 1,2
	  FCOUNT(NC) = 1.E-20
	  FAVR(NC) = 0.
	  FSTD(NC) = 0.
	  F3MOM(NC) = 0.
	  DO N = FLLIM,FUPLIM
	    IF(NC.EQ.1) THEN
		VLT = 10.**(.1*DBSPEC1(N))
	    ELSE
		VLT = 10.**(.1*DBSPEC2(N))
	    ENDIF
	    FCOUNT(NC) = FCOUNT(NC) + VLT
	    FAVR(NC) = FAVR(NC) + VLT*FREQ(N)
	    FSTD(NC) = FSTD(NC) + VLT*FREQ(N)**2
	    F3MOM(NC) = F3MOM(NC) + VLT*FREQ(N)**3
	  ENDDO
	  FAVR(NC) = FAVR(NC)/FCOUNT(NC)
	  FSTD(NC) = FSTD(NC)/FCOUNT(NC) - FAVR(NC)**2
	  FBW(NC) = SQRT(AMAX1(FSTD(NC),0.))
	  SKEW(NC) = F3MOM(NC)/FCOUNT(NC) - 3.*FAVR(NC)*FSTD(NC)
     1		 - FAVR(NC)**3
	ENDDO
C
	AVRPER = 1.E-6
	IF(ZCNT2.NE.0.) AVRPER = 2048./SPS/ZCNT2
	FREQKHZ = .001/AVRPER
C
C	WRITE(56,1111) SCETI4(1),NO_EVT,FREQKHZ,FAVR(1),FAVR(2),FBW(1)
C     1	  ,FBW(2),SKEW(1),SKEW(2)
 1111	FORMAT(I10,I10,F7.3,2F8.0,2E11.3,2E11.3)
C****
C	WRITE(37,*), NO_EVT,XMAX,YMAX,XCOUNT,YCOUNT
C****
C	ANGLE =  -360.*SUNCLOCK/4096. - 45.       ! ANGLE SUN TO +EX AT END
C	DANG = SPINRATE*360./SPS/TWOPI		  ! CHANGE PER SAMPLE
C	THANT = ANGLE + 1024.*DANG + 360.	  ! ANGLE SUN TO +EX AT MIDDLE
C
	FP = 9.*SQRT(DENS)			  ! PLASMA FREQ IN KHZ
C	FCE = .028*BMAG
C	BETA = .402*(TEMPE+TEMPI)/BMAG**2
C
	IF(FREQKHZ.GT..8*FP) THEN
	  PRINT*,'EVENT NO.',NO_EVT,' FREQ', FREQKHZ,' MAX',
     1		MAXCH1,MAXCH2
	  IFOUND = 0
c		to exclude cals
	  if(sceti4(2).lt.010000.or.sceti4(2).gt.011000) then
	      write(54,1054) SCETI4,NO_EVT,MAXCH1,MAXCH2,
     1		XMAX/.0411,YMAX/.00379,FREQKHZ,FP
 1054	  FORMAT(I10,I7,I10,2I4,2E11.3,2F8.2)
	  endif
	  GO TO 100
	ENDIF
	IF(Z1MAX.GT.2.*Z2MAX) THEN
c	  PRINT*,'EVENT NO.',NO_EVT,' A BIG GAP',Z1MAX,Z2MAX
c	  ITEM = 'SUN_ANGLE'
c	  ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
c	  write(55,*) no_evt,sunclock,z1max,z2max
	  IFOUND = 0
	  GO TO 100
	ENDIF
c	the following test eliminated a good event, 14583199 19960527
c	IF(ZCNT1.LT..7*ZCNT2) THEN
c	  PRINT*,'EVENT NO.',NO_EVT,' NOT ENOUGH ZERO CROSSING IN CH 1'
c	  IFOUND = 0
c	  GO TO 100
c	ENDIF
C
C*****	CHECKING
c	PRINT*,'VMATRIX',VMATRIX(1,1),VMATRIX(1,2),VMATRIX(2,2)
c	PRINT*,'EVALS,AXS,PX,PY',EVAL(1),EVAL(2),AXMAJOR,AXMINOR,
c     1		PX,PY
C*****
C
C	PLASMA PARAMETERS, ETC.

C	   write(s,'(i8.8,i6.6)',iostat=ios) s_scet(1), s_scet(2)
C	   s_scet = s(1:4)//'/'//s(5:6)//'/'//s(7:8)//' '//
C	1	s(9:10)//':'//s(11:12)//':'//s(13:14)
C
c	print date, time, event no., freq, Px, Py, Vy/Vx, angles of
c		antenna,B, phiB, mag B or fce, fp
c
c	PRINT*, 'PXTOT,PYTOT,RATIO',PXTOT,PYTOT,XYRATIO
C
C	  WRITE(90,1011) sceti4,NO_EVT,FREQKHZ,PX,PY,SLOPE,ANGTOB,
C     1	     AZMAG,MAGEL,FP,FCE,BETA,XCOUNT,YCOUNT
C 1011	format(I10,I7,I10,F7.2,2E10.3,F8.3,2F7.1,I5,F7.3,F7.4,F8.4,2F7.0)
C
	IF(OK.NE.82) GO TO 100
	return
	end


MODULE PublicPar
!
! Stress histogram parameters
   DOUBLE PRECISION, ALLOCATABLE :: Spect(:,:,:) ! Stress histograms
   INTEGER                       :: nccmax       ! size of 2nd column of stress histograms (number of rows in stress range input files)
   DOUBLE PRECISION              :: R            ! Stress ratio
   INTEGER                       :: nmaxCsr      ! Maximum number of stress range uncertainty values
!
! Inspection parameters
   INTEGER                       :: ninsp        ! number of inspections
   INTEGER                       :: ttd          ! 0 = surface flaws can be detected
					    		                 ! 1 = only through thickness flaws can be detected
   INTEGER, ALLOCATABLE          :: nd(:)        ! number of detected cracks during each inspection
!
! Number of detail locations
   INTEGER                       :: nloc         ! number of potential crack locations
!
! Material parameters
   DOUBLE PRECISION              :: fynom        ! nominal yield stress
   INTEGER                       :: law          ! Crack growth equation
                                                 ! 1 = Forman Mettu
												 ! 2 = BS 7910:2013 in air
!
! Geometry parameters
   INTEGER                       :: LoadType     ! 1 = Membrane loading
                                                 ! 2 = Bending loading
												 ! 3 = Both membrane and bending
   INTEGER                       :: FlawType     ! 1 = Through-thickness flaws in plates
                                                 ! 2 = Surface flaws in plates
												 ! 3 = Through-width flaws in plates
									             ! 4 = semi-circular surface flaw in round bar
												 ! 5 = Corner flaws in plates
												 ! 6 = Semi-circular surface flaw in bolts, solution 2
												 ! 7 = Edge flaws in plates
												 ! 8 = Through-thickness deck plate crack (orthotropic bridge deck)
												 ! 9 = Cope longitudinal girger (raveling) ProRail
   INTEGER                       :: WeldGeometry ! 0 = No weld
                                                 ! 1 = According to fig. M.23
                                                 ! 2 = According to fig. M.24
   DOUBLE PRECISION              :: Bnom         ! nominal plate thickness
   DOUBLE PRECISION              :: p            ! exponent for the dependency of stress on plate thickness (1 for membrane, 2 for bending)
   DOUBLE PRECISION              :: cmax         ! Semi crack length at which end-of-life is assumed if not already fractured
   DOUBLE PRECISION              :: alpha        ! Constraint constant
!   INTEGER, PARAMETER :: ndof = 6
!
END MODULE PublicPar