!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine writecvg(istep,iinc,icutb,iit,ne,ne0,ram,qam,cam,uam,
     &  ithermal)
!
      implicit none
!
!     writes convergence information in the .cvg-file
!
      integer istep,iinc,iit,ne,ne0,ithermal(*),icutb
!
      real*8 ram(*),qam(*),cam(*),uam(*),residforce,corrdisp,
     &  residflux,corrtemp
!
      if(ithermal(1).eq.2) then
         residforce=0.d0
         corrdisp=0.d0
      else
         if(dabs(qam(1)).lt.1.d-30) then
            if(dabs(ram(1)).lt.1.d-30) then
               residforce=1.d-30
            else
               residforce=1.d30
            endif
         else
            residforce=ram(1)/qam(1)*100.d0
         endif
!
         if(dabs(uam(1)).lt.1.d-30) then
            if(dabs(cam(1)).lt.1.d-30) then
               corrdisp=1.d-30
            else
               corrdisp=1.d30
            endif
         else
            corrdisp=cam(1)/uam(1)*100.d0
         endif
      endif
!
      if(ithermal(1).le.1) then
         residflux=0.d0
         corrtemp=0.d0
      else
         if(dabs(qam(2)).lt.1.d-30) then
            if(dabs(ram(2)).lt.1.d-30) then
               residflux=1.d-30
            else
               residflux=1.d30
            endif
         else
            residflux=ram(2)/qam(2)*100.d0
         endif
         if(dabs(uam(2)).lt.1.d-30) then
            if(dabs(cam(2)).lt.1.d-30) then
               corrtemp=1.d-30
            else
               corrtemp=1.d30
            endif
         else
            corrtemp=cam(2)/uam(2)*100.d0
         endif
      endif
!
      write(11,'(2x,i4,2x,i4,2x,i4,2x,i4,2x,i7,4(1x,e11.4))') istep,
     &  iinc,icutb+1,iit,ne-ne0,residforce,corrdisp,residflux,corrtemp
!
      flush(11)
!
      return
      end


!
! CRTM_AtmOptics
!
! Application module for AtmOptics objects.
!
! CREATION HISTORY:
!       Written by:     Quanhua Liu,    quanhua.liu@noaa.gov
!                       Yong Han,       yong.han@noaa.gov
!                       Paul van Delst, paul.vandelst@noaa.gov
!                       08-Jun-2005
!

MODULE CRTM_AtmOptics

  ! ---------------
  ! Environment setup
  ! ---------------
  ! Module use
  USE Type_Kinds           , ONLY: fp
  USE Message_Handler      , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message
  USE CRTM_Parameters      , ONLY: ZERO, ONE, POINT_5, &
                                   MAX_N_LAYERS, &
                                   BS_THRESHOLD, &
                                   SCATTERING_ALBEDO_THRESHOLD
  USE CRTM_AtmOptics_Define, ONLY: CRTM_AtmOptics_type      , &
                                   CRTM_AtmOptics_Associated, &
                                   CRTM_AtmOptics_Create    , &
                                   CRTM_AtmOptics_Zero
  ! Internal variable definition module
  USE AOvar_Define, ONLY: AOvar_type, &
                          AOvar_Associated, &
                          AOvar_Destroy   , &
                          AOvar_Create
  ! Disable implicit typing
  IMPLICIT NONE

  ! ----------
  ! Visibilities
  ! ----------
  ! Everything private by default
  PRIVATE
  ! Datatypes
  PUBLIC :: AOvar_type
  ! Procedures
  PUBLIC :: AOvar_Create

  PUBLIC :: CRTM_No_Scattering
  PUBLIC :: CRTM_Include_Scattering

  PUBLIC :: CRTM_Compute_Transmittance
  PUBLIC :: CRTM_Compute_Transmittance_TL
  PUBLIC :: CRTM_Compute_Transmittance_AD

  PUBLIC :: CRTM_AtmOptics_Combine
  PUBLIC :: CRTM_AtmOptics_Combine_TL
  PUBLIC :: CRTM_AtmOptics_Combine_AD

  PUBLIC :: CRTM_AtmOptics_NoScatterCopy
  PUBLIC :: CRTM_AtmOptics_NoScatterCopy_TL
  PUBLIC :: CRTM_AtmOptics_NoScatterCopy_AD

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

CONTAINS

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

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_No_Scattering
!
! PURPOSE:
!       Pure function to determine if scattering calculations will NOT be
!       performed.
!
! CALLING SEQUENCE:
!       result = CRTM_No_Scattering( AtmOptics )
!
! INPUTS:
!       AtmOptics: The atmospheric optical properties
!                  UNITS:      N/A
!                  TYPE:       CRTM_AtmOptics_type
!                  DIMENSION:  Scalar
!                  ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       result:    Returns
!                    TRUE -  if the maximum single scatter albedo profile
!                            value is less than or equal to the scattering
!                            albedo threshold, OR if the user explicitly
!                            disbles scattering via the Include_Scattering
!                            option.
!                    FALSE - otherwise.
!                  UNITS:      N/A
!                  TYPE:       LOGICAL
!                  DIMENSION:  Scalar
!
!:sdoc-:
!--------------------------------------------------------------------------------

  PURE FUNCTION CRTM_No_Scattering(atmoptics) RESULT(no_scattering)
    TYPE(CRTM_AtmOptics_type), INTENT(IN) :: atmoptics
    LOGICAL :: no_scattering
    no_scattering = .NOT. CRTM_Include_Scattering(atmoptics)
  END FUNCTION CRTM_No_Scattering

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Include_Scattering
!
! PURPOSE:
!       Pure function to determine if scattering calculations will be
!       performed.
!
! CALLING SEQUENCE:
!       result = CRTM_Include_Scattering( AtmOptics )
!
! INPUTS:
!       AtmOptics: The atmospheric optical properties
!                  UNITS:      N/A
!                  TYPE:       CRTM_AtmOptics_type
!                  DIMENSION:  Scalar
!                  ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       result:    Returns
!                    TRUE -  if the maximum single scatter albedo profile
!                            value is greater than the scattering albedo
!                            threshold, AND if the user has NOT explicitly
!                            disbled scattering via the Include_Scattering
!                            option.
!                    FALSE - otherwise.
!                  UNITS:      N/A
!                  TYPE:       LOGICAL
!                  DIMENSION:  Scalar
!
!:sdoc-:
!--------------------------------------------------------------------------------

  PURE FUNCTION CRTM_Include_Scattering(atmoptics) RESULT(include_scattering)
    TYPE(CRTM_AtmOptics_type), INTENT(IN) :: atmoptics
    LOGICAL :: include_scattering
    ! This test is different from previous incarnations in that before the
    !   test turned OFF scattering if the AtmOptics single scatter albedo was
    !   LESS THAN the threshold (i.e. greater than or equal to).
    ! Now we include scattering if the AtmOptics single scatter albedo is
    !   GREATER THAN (but NOT equal to) the threshold.
    ! Confused? Sorry.
    include_scattering = (MAXVAL(atmoptics%Single_Scatter_Albedo) > SCATTERING_ALBEDO_THRESHOLD) .AND. &
                         atmoptics%Include_Scattering
  END FUNCTION CRTM_Include_Scattering

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Compute_Transmittance
!
! PURPOSE:
!       Subroutine to compute the total atmospheric transmittance.
!
! CALLING SEQUENCE:
!       CALL CRTM_Compute_Transmittance( AtmOptics, Transmittance )
!
! INPUTS:
!       AtmOptics:      The atmospheric optical properties
!                       UNITS:      N/A
!                       TYPE:       CRTM_AtmOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Transmittance:  The total atmospheric transmittance derived from
!                       the optical depth component of AtmOptics.
!                       UNITS:      N/A
!                       TYPE:       REAL(fp)
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE CRTM_Compute_Transmittance( atmoptics, transmittance )
    TYPE(CRTM_AtmOptics_type), INTENT(IN)  :: atmoptics
    REAL(fp)                 , INTENT(OUT) :: transmittance
    INTEGER :: k
    k = atmoptics%n_layers
    transmittance = EXP(-ONE*SUM(atmoptics%optical_depth(1:k)))
  END SUBROUTINE CRTM_Compute_Transmittance

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Compute_Transmittance_TL
!
! PURPOSE:
!       Subroutine to compute the tangent-linear total atmospheric transmittance.
!
! CALLING SEQUENCE:
!       CALL CRTM_Compute_Transmittance_TL( AtmOptics   , &
!                                           AtmOptics_TL, &
!                                           Transmittance_TL )
!
! INPUTS:
!       AtmOptics:         The atmospheric optical properties
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
!       AtmOptics_TL:      The tangent-linear atmospheric optical properties
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Transmittance_TL:  The tangent-linear of the total atmospheric
!                          transmittance derived from the optical depth
!                          component of AtmOptics.
!                          UNITS:      N/A
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE CRTM_Compute_Transmittance_TL( &
    atmoptics       , &  ! Input
    atmoptics_TL    , &  ! Input
    transmittance_TL  )  ! Output
    ! Arguments
    TYPE(CRTM_AtmOptics_type), INTENT(IN)  :: atmoptics
    TYPE(CRTM_AtmOptics_type), INTENT(IN)  :: atmoptics_TL
    REAL(fp)                 , INTENT(OUT) :: transmittance_TL
    ! Local variables
    INTEGER :: k
    REAL(fp) :: transmittance

    k = atmoptics%n_layers
    transmittance    = EXP(-ONE*SUM(atmoptics%optical_depth(1:k)))
    transmittance_TL = -transmittance * SUM(atmoptics_TL%optical_depth(1:k))
  END SUBROUTINE CRTM_Compute_Transmittance_TL

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Compute_Transmittance_AD
!
! PURPOSE:
!       Subroutine to compute the adjoint of the total atmospheric transmittance.
!
! CALLING SEQUENCE:
!       CALL CRTM_Compute_Transmittance_AD( AtmOptics       , &
!                                           Transmittance_AD, &
!                                           AtmOptics_AD      )
!
! INPUTS:
!       AtmOptics:         The atmospheric optical properties
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
!       Transmittance_AD:  The adjoint of the total atmospheric transmittance.
!                          *** Set to ZERO upon exit ***
!                          UNITS:      N/A
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
!       AtmOptics_AD:      The adjoint atmospheric optical properties.
!                          *** Must be defined upon input ***
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE CRTM_Compute_Transmittance_AD( &
    atmoptics       , &  ! Input
    transmittance_AD, &  ! Input
    atmoptics_AD      )  ! Output
    ! Arguments
    TYPE(CRTM_AtmOptics_type), INTENT(IN)     :: atmoptics
    REAL(fp)                 , INTENT(IN OUT) :: transmittance_AD
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: atmoptics_AD
    ! Local variables
    INTEGER :: k
    REAL(fp) :: transmittance, t_delstar_t

    k = atmoptics%n_layers
    transmittance = EXP(-ONE*SUM(atmoptics%optical_depth(1:k)))
    t_delstar_t   = transmittance*transmittance_AD
    DO k = 1, atmoptics%n_layers
      atmoptics_AD%optical_depth(k) = atmoptics_AD%optical_depth(k) - t_delstar_t
    END DO
    transmittance_AD = ZERO
  END SUBROUTINE CRTM_Compute_Transmittance_AD

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_AtmOptics_Combine
!
! PURPOSE:
!       Subroutine to combine the optical properties from AtmAbsorption,
!       CloudScatter, and AerosolScatter calculations.
!
! CALLING SEQUENCE:
!       CALL CRTM_AtmOptics_Combine( AtmOptics, &
!                                    AOvar      )
!
! OUTPUTS:
!       AtmOptics:      The combined atmospheric optical properties
!                       UNITS:      N/A
!                       TYPE:       CRTM_AtmOptics_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!       AOvar:          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:       AOvar_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE CRTM_AtmOptics_Combine( &
    AtmOptics, &  ! Output
    AOvar      )  ! Internal variable output
    ! Arguments
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics
    TYPE(AOvar_type)         , INTENT(IN OUT) :: AOvar
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_Combine'
    ! Local variables
    INTEGER :: i, k, l

    ! Initialise scattering optical depth sum
    AtmOptics%Scattering_Optical_Depth = ZERO

    ! No scattering case
    IF( (.NOT. AtmOptics%Include_Scattering) .OR. &
        AtmOptics%n_Legendre_Terms == 0 ) RETURN

    ! Loop over atmospheric layers
    Layer_Loop: DO k = 1, AtmOptics%n_Layers

      ! Save the unmodified optical parameters
      AOvar%Optical_Depth(k) = AtmOptics%Optical_Depth(k)
      AOvar%bs(k)            = AtmOptics%Single_Scatter_Albedo(k)
      ! ...Initialise scattering dependent terms
      AOvar%w(k) = ZERO

      ! Only proceed if the total optical depth is significant
      Significant_Scattering: IF( AOvar%bs(k) > BS_THRESHOLD ) THEN

        AOvar%w(k) = AtmOptics%Single_Scatter_Albedo(k) / AtmOptics%Optical_Depth(k)
        AtmOptics%Asymmetry_Factor(k) = AtmOptics%Asymmetry_Factor(k) / &
                                        AtmOptics%Single_Scatter_Albedo(k)
        DO i = 1, AtmOptics%n_Phase_Elements
          DO l = 1, AtmOptics%n_Legendre_Terms
            AtmOptics%Phase_Coefficient(l,i,k) = AtmOptics%Phase_Coefficient(l,i,k) / &
                                                 AtmOptics%Single_Scatter_Albedo(k)
          END DO
          ! ...Normalization requirement for energy conservation
          AtmOptics%Phase_Coefficient(0,i,k) = POINT_5
        END DO

        IF ( AtmOptics%Delta_Adjust ) THEN
          AtmOptics%Delta_Truncation(k) = AtmOptics%Phase_Coefficient(AtmOptics%n_Legendre_Terms,1,k)
        ELSE
          AtmOptics%Delta_Truncation(k) = ZERO
        END IF

        ! Redfine the total optical depth and single scattering
        ! albedo for the delta-function adjustment
        AtmOptics%Optical_Depth(k) = ( ONE - ( AtmOptics%Delta_Truncation(k) * AOvar%w(k) )) * &
                                     AtmOptics%Optical_Depth(k)
        AtmOptics%Single_Scatter_Albedo(k) = ( ONE - AtmOptics%Delta_Truncation(k) ) * AOvar%w(k)   / &
                                             ( ONE - ( AtmOptics%Delta_Truncation(k) * AOvar%w(k) ) )

      END IF Significant_Scattering

      ! Compute the vertically integrated scattering optical depth
      AtmOptics%Scattering_Optical_Depth = AtmOptics%Scattering_Optical_Depth + &
                                           (AOvar%w(k) * AOvar%Optical_Depth(k))

    END DO Layer_Loop

  END SUBROUTINE CRTM_AtmOptics_Combine

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_AtmOptics_Combine_TL
!
! PURPOSE:
!       Subroutine to combine the tangent-linear optical properties from
!       AtmAbsorption, CloudScatter, and AerosolScatter calculations.
!
! CALLING SEQUENCE:
!       CALL CRTM_AtmOptics_Combine_TL( AtmOptics   , &
!                                       AtmOptics_TL, &
!                                       AOvar         )
! INPUTS:
!       AtmOptics:         Combined atmospheric optical properties.
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
!       AOvar:             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 this module.
!                          UNITS:      N/A
!                          TYPE:       AOvar_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
! OUTPUT:
!       AtmOptics_TL:      Tangent-linear combined atmospheric optical properties.
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE CRTM_AtmOptics_Combine_TL( &
    AtmOptics   , &  ! FWD Input
    AtmOptics_TL, &  ! TL Output
    AOvar         )  ! Internal variable input
    ! Arguments
    TYPE(CRTM_AtmOptics_type), INTENT(IN)     :: AtmOptics
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics_TL
    TYPE(AOvar_type)         , INTENT(IN)     :: AOvar
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_Combine_TL'
    ! Local variables
    INTEGER :: i, k, l
    REAL(fp) :: optical_depth_TL
    REAL(fp) :: w_TL

    ! Initialise tangent-linear scattering optical depth sum
    AtmOptics_TL%Scattering_Optical_Depth = ZERO

    ! No scattering case
    IF( (.NOT. AtmOptics%Include_Scattering) .OR. &
        AtmOptics%n_Legendre_Terms == 0 ) RETURN

    ! Loop over atmospheric layers
    Layer_Loop: DO k = 1, AtmOptics%n_Layers

      ! Save the unmodified optical parameters
      optical_depth_TL = AtmOptics_TL%Optical_Depth(k)
      ! ...Initialise scattering dependent terms
      w_TL = ZERO

      ! Only proceed if the total optical depth is significant
      Significant_Scattering: IF( AOvar%bs(k) > BS_THRESHOLD ) THEN

        w_TL = ( AtmOptics_TL%Single_Scatter_Albedo(k) / AOvar%Optical_Depth(k) ) - &
               ( AtmOptics_TL%Optical_Depth(k) * AOvar%w(k) / AOvar%Optical_Depth(k) )
        DO i = 1, AtmOptics%n_Phase_Elements
          DO l = 1, AtmOptics%n_Legendre_Terms
             AtmOptics_TL%Phase_Coefficient(l,i,k) = &
               ( AtmOptics_TL%Phase_Coefficient(l,i,k) - &
                 (AtmOptics%Phase_Coefficient(l,i,k) * AtmOptics_TL%Single_Scatter_Albedo(k)) ) / AOvar%bs(k)
          END DO
          ! ...Normalization requirement for energy conservation
          AtmOptics_TL%Phase_Coefficient(0,i,k) = ZERO
        END DO

        IF ( AtmOptics%Delta_Adjust ) THEN
          AtmOptics_TL%Delta_Truncation(k) = AtmOptics_TL%Phase_Coefficient(AtmOptics%n_Legendre_Terms,1,k)
        ELSE
          AtmOptics_TL%Delta_Truncation(k) = ZERO
        END IF

        ! Redefine the tangent-linear total optical depth and
        ! single scattering albedo for the delta-function adjustment
        !
        ! The expressions below are ordered to make the adjoint
        ! form easy to determine from the TL form.

        !  The optical depth
        !
        !    tau = ( 1 - d.w ) . tau
        !
        !  so,
        !
        !    tau_TL = ( 1 - d.w ).tau_TL - d.tau.w_TL - w.tau.d_TL
        !
        !  Note that the optical depth from the AOvar structure is
        !  used on the RHS of these expressions.
          AtmOptics_TL%Optical_Depth(k) = &
              ( ( ONE - ( AtmOptics%Delta_Truncation(k) * AOvar%w(k) ) ) * AtmOptics_TL%Optical_Depth(k) ) - &
              ( AtmOptics%Delta_Truncation(k) * AOvar%Optical_Depth(k) * w_TL ) - &
              ( AOvar%w(k) * AOvar%Optical_Depth(k) * AtmOptics_TL%Delta_Truncation(k) )

        !  The single scatter albedo, SSA
        !
        !         (1 - d).w
        !  SSA = -----------
        !          1 - d.w
        !
        !  so,
        !
        !            ( 1 - d + SSA.d )              ( SSA - 1 ).w
        !  SSA_TL = ------------------- . w_TL  +  --------------- . d_TL
        !                1 - d.w                       1 - d.w
        !
          AtmOptics_TL%Single_Scatter_Albedo(k) = &
            ( ( ( ONE - AtmOptics%Delta_Truncation(k) + &
                  ( AtmOptics%Single_Scatter_Albedo(k)*AtmOptics%Delta_Truncation(k) ) ) * w_TL ) + &
              ( ( AtmOptics%Single_Scatter_Albedo(k) - ONE ) * AOvar%w(k) * AtmOptics_TL%Delta_Truncation(k) ) ) / &
            ( ONE - ( AtmOptics%Delta_Truncation(k) * AOvar%w(k) ) )

      END IF Significant_Scattering

      ! Compute the tangent-linear vertically integrated scattering optical depth
      AtmOptics_TL%Scattering_Optical_Depth = AtmOptics_TL%Scattering_Optical_Depth + &
                                              (AOvar%w(k) * optical_depth_TL) + &
                                              (AOvar%Optical_Depth(k) * w_TL)

    END DO Layer_Loop

  END SUBROUTINE CRTM_AtmOptics_Combine_TL

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_AtmOptics_Combine_AD
!
! PURPOSE:
!       Subroutine to compute the adjoint form of the optical properties
!       from AtmAbsorption, CloudScatter, and AerosolScatter calculations.
!
! CALLING SEQUENCE:
!       CALL CRTM_AtmOptics_Combine_AD( AtmOptics,    &
!                                       AtmOptics_AD, &
!                                       AOvar   )
!
! INPUTS:
!       AtmOptics:         Structure containing the combined atmospheric optical
!                          parameters
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
!       AOvar:             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_AtmOptics module.
!                          UNITS:      N/A
!                          TYPE:       AOvar_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN)
!
!       AtmOptics_AD:      Structure containing the combined adjoint atmospheric
!                          optical parameters.
!                          NOTE: The components of this structures are all zeroed
!                                upon exit from this routine.
!                          UNITS:      N/A
!                          TYPE:       CRTM_AtmOptics_type
!                          DIMENSION:  Scalar
!                          ATTRIBUTES: INTENT(IN OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE CRTM_AtmOptics_Combine_AD( &
    AtmOptics   , &  ! FWD Input
    AtmOptics_AD, &  ! AD  Input
    AOvar         )  ! Internal variable input
    ! Arguments
    TYPE(CRTM_AtmOptics_type), INTENT(IN)     :: AtmOptics
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics_AD
    TYPE(AOvar_type)         , INTENT(IN)     :: AOvar
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_Combine_AD'
    ! Local variables
    INTEGER :: i, k, l
    REAL(fp) :: w_AD

    ! No scattering case
    IF( (.NOT. AtmOptics%Include_Scattering) .OR. &
        AtmOptics%n_Legendre_Terms == 0 ) RETURN

    ! Begin layer loop
    Layer_Loop: DO k = AtmOptics%n_Layers, 1, -1

      w_AD  =  ZERO

      ! Only proceed if the scattering is significant
      Significant_Scattering: IF( AOvar%bs(k) > BS_THRESHOLD) THEN

        IF ( AtmOptics%Delta_Adjust ) THEN

        ! Compute the adjoint total optical depth and single
        ! scattering albedo for the delta function adjustment

        !  The tangent-linear single scatter albedo, SSA_TL
        !
        !              ( 1 - d + SSA.d )              ( SSA - 1 ).w
        !    SSA_TL = ------------------- . w_TL  +  --------------- . d_TL
        !                   1 - d.w                      1 - d.w
        !
        !  so,
        !                    ( SSA - 1 ).w
        !    d_AD = d_AD + ---------------- . SSA_AD
        !                       1 - d.w
        !
        !                   ( 1 - d + SSA.d )
        !    w_AD = w_AD + ------------------- . SSA_AD
        !                        1 - d.w
        !
        !    SSA_AD = 0

          AtmOptics_AD%Delta_Truncation(k) = AtmOptics_AD%Delta_Truncation(k) + &
            ( ( AtmOptics%Single_Scatter_Albedo(k) - ONE ) * AOvar%w(k) * AtmOptics_AD%Single_Scatter_Albedo(k) / &
              ( ONE - ( AtmOptics%Delta_Truncation(k) * AOvar%w(k) ) ) )

          w_AD = w_AD + ( ( ONE - AtmOptics%Delta_Truncation(k) + &
                            ( AtmOptics%Single_Scatter_Albedo(k)*AtmOptics%Delta_Truncation(k) ) ) * &
                          AtmOptics_AD%Single_Scatter_Albedo(k) / &
                          ( ONE - ( AtmOptics%Delta_Truncation(k) * AOvar%w(k) ) ) )

          AtmOptics_AD%Single_Scatter_Albedo(k) = ZERO

        !  The tangent-linear optical depth, tau_TL
        !
        !    tau_TL = ( 1 - d.w ).tau_TL - d.tau.w_TL - w.tau.d_TL
        !
        !  so,
        !
        !    d_AD = d_AD - w.tau.tau_AD
        !
        !    w_AD = w_AD - d.tau.tau_AD
        !
        !    tau_AD = ( 1 - d.w ).tau_AD
        !
        !  Note that the optical depth from the AOvar structure is
        !  used on the RHS of the above expressions.

          AtmOptics_AD%Delta_Truncation(k) = AtmOptics_AD%Delta_Truncation(k) - &
            ( AOvar%w(k)                    * &  ! w
              AOvar%Optical_Depth(k)        * &  ! tau
              AtmOptics_AD%Optical_Depth(k) )  ! tau_AD

          w_AD = w_AD - ( AtmOptics%Delta_Truncation(k) * &  ! d
                          AOvar%Optical_Depth(k)          * &  ! tau
                          AtmOptics_AD%Optical_Depth(k)   )  ! tau_AD

          AtmOptics_AD%Optical_Depth(k) = ( ONE - ( AtmOptics%Delta_Truncation(k) * AOvar%w(k) ) ) * &
                                        AtmOptics_AD%Optical_Depth(k)

        !  Delta truncation adjoint
          l = AtmOptics%n_Legendre_Terms
!          IF ( AtmOptics%Delta_Adjust ) THEN
            AtmOptics_AD%Phase_Coefficient(l,1,k) = AtmOptics_AD%Phase_Coefficient(l,1,k) + &
                                                    AtmOptics_AD%Delta_Truncation(k)
            AtmOptics_AD%Delta_Truncation(k) = ZERO
!          ELSE
!            AtmOptics_AD%Delta_Truncation(k) = ZERO
!          END IF

        ELSE
          AtmOptics_AD%Delta_Truncation(k) = ZERO
        END IF

        DO i = 1, AtmOptics%n_Phase_Elements
          ! Normalization requirement for energy conservation
          AtmOptics_AD%Phase_Coefficient(0,i,k) = ZERO
          DO l = 1, AtmOptics%n_Legendre_Terms
             AtmOptics_AD%Single_Scatter_Albedo(k) = AtmOptics_AD%Single_Scatter_Albedo(k) - &
               AtmOptics%Phase_Coefficient(l,i,k)*AtmOptics_AD%Phase_Coefficient(l,i,k)/AOvar%bs(k)
             AtmOptics_AD%Phase_Coefficient(l,i,k) = ( AtmOptics_AD%Phase_Coefficient(l,i,k)/AOvar%bs(k) )
          END DO
        END DO

        AtmOptics_AD%Single_Scatter_Albedo(k) = AtmOptics_AD%Single_Scatter_Albedo(k) + &
                                                w_AD / AOvar%Optical_Depth(k)
        AtmOptics_AD%Optical_Depth(k) = AtmOptics_AD%Optical_Depth(k) - &
                                        w_AD*AOvar%w(k) / AOvar%Optical_Depth(k)

      END IF Significant_Scattering

    END DO Layer_Loop

  END SUBROUTINE CRTM_AtmOptics_Combine_AD

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_AtmOptics_NoScatterCopy
!
! PURPOSE:
!       Function to copy an instance of a CRTM AtmOptics object
!       but without the scattering information included.
!
! CALLING SEQUENCE:
!       Error_Status = CRTM_AtmOptics_NoScatterCopy( AtmOptics, AtmOptics_Clear )
!
! INPUTS:
!       AtmOptics:       AtmOptics object to copy
!                        UNITS:      N/A
!                        TYPE:       CRTM_AtmOptics_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       AtmOptics_Clear: Copy of the input AtmOptics object but without the
!                        scattering information.
!                        UNITS:      N/A
!                        TYPE:       CRTM_AtmOptics_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 operation was successful
!                           == FAILURE an error occurred
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!
!:sdoc-:
!--------------------------------------------------------------------------------

  FUNCTION CRTM_AtmOptics_NoScatterCopy( ao, ao_clear ) RESULT( err_stat )
    ! Arguments
    TYPE(CRTM_AtmOptics_type), INTENT(IN)  :: ao
    TYPE(CRTM_AtmOptics_type), INTENT(OUT) :: ao_clear
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_NoScatterCopy'
    ! Local variables
    CHARACTER(ML) :: err_msg

    ! Set up
    err_stat = SUCCESS
    ! ...Check input
    IF ( .NOT. CRTM_AtmOptics_Associated(ao) ) THEN
      err_stat = FAILURE
      err_msg = 'Input AtmOptics structure not allocated'
      CALL Display_Message( ROUTINE_NAME, err_msg, err_stat )
      RETURN
    END IF

    ! Create the output structure
    CALL CRTM_AtmOptics_Create( ao_clear   , &
                                ao%n_Layers, &
                                0          , &  ! No Legendre terms
                                0            )  ! No phase element terms
    IF ( .NOT. CRTM_AtmOptics_Associated(ao_clear) ) THEN
      err_stat = FAILURE
      err_msg = 'Error allocating output Clear-Sky AtmOptics structure'
      CALL Display_Message( ROUTINE_NAME, err_msg, err_stat )
      RETURN
    END IF

    ! Set/Copy over the clear-sky data
    ao_clear%Include_Scattering = .FALSE.
    ao_clear%Optical_Depth      = ao%Optical_Depth(1:ao%n_Layers)

  END FUNCTION CRTM_AtmOptics_NoScatterCopy

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_AtmOptics_NoScatterCopy_TL
!
! PURPOSE:
!       Function to copy an instance of a tangent-linear CRTM AtmOptics object
!       but without the scattering information included.
!!
! CALLING SEQUENCE:
!       Error_Status = CRTM_AtmOptics_NoScatterCopy_TL( ao, ao_TL, ao_clear_TL )
!
! INPUTS:
!       ao:              Forward AtmOptics object for consistency checking
!                        UNITS:      N/A
!                        TYPE:       CRTM_AtmOptics_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       ao_TL:           Tangent-linear AtmOptics object to copy. This object
!                        must be the tangent-linear equivalent of the input
!                        forward AtmOptics object.
!                        This
!                        UNITS:      N/A
!                        TYPE:       CRTM_AtmOptics_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       ao_clear_TL:     Copy of the input AtmOptics tangent-linear object but
!                        without scattering information.
!                        UNITS:      N/A
!                        TYPE:       CRTM_AtmOptics_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 operation was successful
!                           == FAILURE an error occurred
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!
!:sdoc-:
!--------------------------------------------------------------------------------

  FUNCTION CRTM_AtmOptics_NoScatterCopy_TL( &
    ao         , &  ! FWD input
    ao_TL      , &  ! TL  input
    ao_clear_TL) &  ! TL  output
  RESULT( err_stat )
    ! Arguments
    TYPE(CRTM_AtmOptics_type), INTENT(IN)  :: ao
    TYPE(CRTM_AtmOptics_type), INTENT(IN)  :: ao_TL
    TYPE(CRTM_AtmOptics_type), INTENT(OUT) :: ao_clear_TL
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_NoScatterCopy_TL'
    ! Local variables
    CHARACTER(ML) :: err_msg

    ! Set up
    err_stat = SUCCESS
    ! ...Check input allocation
    IF ( .NOT. CRTM_AtmOptics_Associated(ao   ) .OR. &
         .NOT. CRTM_AtmOptics_Associated(ao_TL) ) THEN
      err_stat = FAILURE
      err_msg = 'Input AtmOptics structures not allocated'
      CALL Display_Message( ROUTINE_NAME, err_msg, err_stat )
      RETURN
    END IF
    ! ...Dimension consistency
    IF ( (ao%n_Layers         /= ao_TL%n_Layers        ) .OR. &
         (ao%n_Legendre_Terms /= ao_TL%n_Legendre_Terms) .OR. &
         (ao%n_Phase_Elements /= ao_TL%n_Phase_Elements) ) THEN
      err_stat = FAILURE
      err_msg = 'Input AtmOptics structures have incongruent dimensions'
      CALL Display_Message( ROUTINE_NAME, err_msg, err_stat )
      RETURN
    END IF

    ! Create the output structure
    CALL CRTM_AtmOptics_Create( ao_clear_TL   , &
                                ao_TL%n_Layers, &
                                0             , &  ! No Legendre terms
                                0               )  ! No phase element terms
    IF ( .NOT. CRTM_AtmOptics_Associated(ao_clear_TL) ) THEN
      err_stat = FAILURE
      err_msg = 'Error allocating output Clear-Sky AtmOptics structure'
      CALL Display_Message( ROUTINE_NAME, err_msg, err_stat )
      RETURN
    END IF

    ! Set/Copy over the clear-sky data
    ao_clear_TL%Include_Scattering = .FALSE.
    ao_clear_TL%Optical_Depth      = ao_TL%Optical_Depth(1:ao_TL%n_Layers)

  END FUNCTION CRTM_AtmOptics_NoScatterCopy_TL

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_AtmOptics_NoScatterCopy_AD
!
! PURPOSE:
!       Function to perform the adjoint copy of an instance of the CRTM
!       AtmOptics object without the scattering information included.
!
! CALLING SEQUENCE:
!       Error_Status = CRTM_AtmOptics_NoScatterCopy_AD( ao, ao_clear_AD, ao_AD )
!
! INPUTS:
!       ao:              AtmOptics object for consistency checking
!                        UNITS:      N/A
!                        TYPE:       CRTM_AtmOptics_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       ao_clear_AD:     Adjoint Clear-Sky AtmOptics structure to copy
!                        UNITS:      N/A
!                        TYPE:       CRTM_AtmOptics_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       ao_AD:           Adjoint copy of the input AtmOptics. This object
!                        must be the adjoint equivalent of the input
!                        forward AtmOptics object.
!                        UNITS:      N/A
!                        TYPE:       CRTM_AtmOptics_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 operation was successful
!                           == FAILURE an error occurred
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!
!:sdoc-:
!--------------------------------------------------------------------------------

  FUNCTION CRTM_AtmOptics_NoScatterCopy_AD( &
    ao         , &  ! FWD input
    ao_clear_AD, &  ! AD  input
    ao_AD      ) &  ! AD  output
  RESULT( err_stat )
    ! Arguments
    TYPE(CRTM_AtmOptics_type), INTENT(IN)     :: ao
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: ao_clear_AD
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: ao_AD
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CRTM_AtmOptics_NoScatterCopy_AD'
    ! Local variables
    CHARACTER(ML) :: err_msg
    INTEGER :: k

    ! Set up
    err_stat = SUCCESS
    ! ...Check input allocation
    IF ( .NOT. CRTM_AtmOptics_Associated(ao         ) .OR. &
         .NOT. CRTM_AtmOptics_Associated(ao_clear_AD) .OR. &
         .NOT. CRTM_AtmOptics_Associated(ao_AD      ) ) THEN
      err_stat = FAILURE
      err_msg = 'Input AtmOptics structures not allocated'
      CALL Display_Message( ROUTINE_NAME, err_msg, err_stat )
      RETURN
    END IF
    ! ...Dimensional consistency
    IF ( (ao%n_Layers         /= ao_AD%n_Layers        ) .OR. &
         (ao%n_Legendre_Terms /= ao_AD%n_Legendre_Terms) .OR. &
         (ao%n_Phase_Elements /= ao_AD%n_Phase_Elements) ) THEN
      err_stat = FAILURE
      err_msg = 'Input AtmOptics and AtmOptics_AD structures have incongruent dimensions'
      CALL Display_Message( ROUTINE_NAME, err_msg, err_stat )
      RETURN
    END IF
    IF ( ao_clear_AD%n_Layers /= ao_AD%n_Layers ) THEN
      err_stat = FAILURE
      err_msg = 'Input AtmOptics_Clear_AD structure has incongruent dimensions'
      CALL Display_Message( ROUTINE_NAME, err_msg, err_stat )
      RETURN
    END IF
    ! ...Non-layer dependent data consistency
    IF ( (ao%Include_Scattering .NEQV. ao_AD%Include_Scattering) .OR. &
         ao_clear_AD%Include_Scattering ) THEN
      err_stat = FAILURE
      err_msg = 'AtmOptics structures have incongruent Scattering flags'
      CALL Display_Message( ROUTINE_NAME, err_msg, err_stat )
      RETURN
    END IF

    ! Adjoint copy of data
    k = ao%n_Layers
    ao_AD%Optical_Depth(1:k) = ao_AD%Optical_Depth(1:k) + ao_clear_AD%Optical_Depth(1:k)

    ! Zero the clear result, as it has no more impact
    CALL CRTM_AtmOptics_Zero( ao_clear_AD )

  END FUNCTION CRTM_AtmOptics_NoScatterCopy_AD

END MODULE CRTM_AtmOptics


!
!  Copyright 2017-2019 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
!=======================================================================
!=======================================================================

subroutine calcAext
!$ use omp_lib
use salmon_parallel, only: nproc_id_global
use salmon_communication, only: comm_is_root, comm_summation
use scf_data
implicit none
integer :: j2
integer :: ipulse
real(8) :: env_trigon_1
real(8) :: env_trigon_2

select case(ikind_eext)
  case(0)
    A_ext(1:3,:)=0.d0
    A_ext(1,:)=Fst*epdir_re1(1)
    A_ext(2,:)=Fst*epdir_re1(2)
    A_ext(3,:)=Fst*epdir_re1(3)
  case(1,15)
    A_ext(1:3,:)=0.d0
    do itt=Miter_rt+1,itotNtime+1
      if(dt*dble(itt) <= pulse_tw1)then
        ipulse=1
        call calc_env_trigon(ipulse,env_trigon_1)
        do j2=1,3
          A_ext(j2,itt)=A_ext(j2,itt)+amplitude1*epdir_re1(j2)*env_trigon_1
        end do
      end if
      if(dt*dble(itt)-t1_t2 >= 1.d-12 .and. dt*dble(itt)-t1_t2 <= pulse_tw2)then
        ipulse=2
        call calc_env_trigon(ipulse,env_trigon_2)
        do j2=1,3
          A_ext(j2,itt)=A_ext(j2,itt)+amplitude1*epdir_re1(j2)*env_trigon_2
        enddo
      end if
    end do
end select

return

end subroutine calcAext


!
! test_VerticalCoordinates
!
! Test program for the CRTM K-Matrix function using different vertical
! coordinates from the training set, under clear sky conditions.
!
!

PROGRAM test_VerticalCoordinates

  ! ============================================================================
  ! **** ENVIRONMENT SETUP FOR RTM USAGE ****
  !
  ! Module usage
  USE CRTM_Module
  ! Disable all implicit typing
  IMPLICIT NONE
  ! ============================================================================

  ! ----------
  ! Parameters
  ! ----------
  CHARACTER(*), PARAMETER :: PROGRAM_NAME   = 'test_VerticalCoordinates'
  CHARACTER(*), PARAMETER :: COEFFICIENTS_PATH = './testinput/'
  CHARACTER(*), PARAMETER :: RESULTS_PATH = './results/k_matrix/'

  ! ============================================================================
  ! 0. **** SOME SET UP PARAMETERS FOR THIS TEST ****
  !
  ! Profile dimensions...
  INTEGER, PARAMETER :: N_PROFILES   = 2
  INTEGER, PARAMETER :: N_LAYERS     = 92
  INTEGER, PARAMETER :: N_NAM_LAYERS = 60
  INTEGER, PARAMETER :: N_GFS_LAYERS = 64
  INTEGER, PARAMETER :: N_ABSORBERS  = 2
  INTEGER, PARAMETER :: N_CLOUDS     = 0
  INTEGER, PARAMETER :: N_AEROSOLS   = 0
  ! ...but only ONE Sensor at a time
  INTEGER, PARAMETER :: N_SENSORS = 1

!!$  INTEGER, PARAMETER ::        INVALID_AEROSOL = 0
!!$  INTEGER, PARAMETER ::           DUST_AEROSOL = 1
!!$  INTEGER, PARAMETER ::   SEASALT_SSAM_AEROSOL = 2
!!$  INTEGER, PARAMETER ::  SEASALT_SSCM1_AEROSOL = 3
!!$  INTEGER, PARAMETER ::  SEASALT_SSCM2_AEROSOL = 4
!!$  INTEGER, PARAMETER ::  SEASALT_SSCM3_AEROSOL = 5
!!$  INTEGER, PARAMETER :: ORGANIC_CARBON_AEROSOL = 6
!!$  INTEGER, PARAMETER ::   BLACK_CARBON_AEROSOL = 7
!!$  INTEGER, PARAMETER ::        SULFATE_AEROSOL = 8

  ! Test GeometryInfo angles. The test scan angle is based
  ! on the default Re (earth radius) and h (satellite height)
  REAL(fp), PARAMETER :: ZENITH_ANGLE = 30.0_fp
  REAL(fp), PARAMETER :: SCAN_ANGLE   = 26.37293341421_fp
  REAL(fp), PARAMETER :: SOURCE_ZENITH_ANGLE = 0.0_fp
  ! ============================================================================

  ! ---------
  ! Variables
  ! ---------
  CHARACTER(256) :: Message
  CHARACTER(256) :: Version
  CHARACTER(256) :: Sensor_Id
  INTEGER :: Error_Status
  INTEGER :: Allocate_Status
  INTEGER :: n_Channels
  INTEGER :: l, m
  ! Declarations for Jacobian comparisons
  INTEGER :: n_la, n_ma
  INTEGER :: n_ls, n_ms
  INTEGER :: n_NAM_la, n_NAM_ma
  INTEGER :: n_NAM_ls, n_NAM_ms
  INTEGER :: n_GFS_la, n_GFS_ma
  INTEGER :: n_GFS_ls, n_GFS_ms
  CHARACTER(256) :: atmk_File, sfck_File
  CHARACTER(256) :: atmk_NAM_File, sfck_NAM_File
  CHARACTER(256) :: atmk_GFS_File, sfck_GFS_File
  TYPE(CRTM_Atmosphere_type), ALLOCATABLE :: atm_k(:,:)
  TYPE(CRTM_Atmosphere_type), ALLOCATABLE :: atm_NAM_k(:,:)
  TYPE(CRTM_Atmosphere_type), ALLOCATABLE :: atm_GFS_k(:,:)
  TYPE(CRTM_Surface_type)   , ALLOCATABLE :: sfc_k(:,:)
  TYPE(CRTM_Surface_type)   , ALLOCATABLE :: sfc_NAM_k(:,:)
  TYPE(CRTM_Surface_type)   , ALLOCATABLE :: sfc_GFS_k(:,:)

  ! ============================================================================
  ! 1. **** DEFINE THE CRTM INTERFACE STRUCTURES ****
  !
  TYPE(CRTM_ChannelInfo_type)             :: ChannelInfo(N_SENSORS)
  TYPE(CRTM_Geometry_type)                :: Geometry(N_PROFILES)
  TYPE(CRTM_Options_type)                 :: Options(N_PROFILES)

  ! Define the FORWARD variables
  TYPE(CRTM_Atmosphere_type)              :: Atm(N_PROFILES)
  TYPE(CRTM_Atmosphere_type)              :: Atm_NAM(N_PROFILES)
  TYPE(CRTM_Atmosphere_type)              :: Atm_GFS(N_PROFILES)
  TYPE(CRTM_Surface_type)                 :: Sfc(N_PROFILES)
  TYPE(CRTM_RTSolution_type), ALLOCATABLE :: RTSolution(:,:)
  TYPE(CRTM_RTSolution_type), ALLOCATABLE :: RTSolution_NAM(:,:)
  TYPE(CRTM_RTSolution_type), ALLOCATABLE :: RTSolution_GFS(:,:)

  ! Define the K-MATRIX variables
  TYPE(CRTM_Atmosphere_type), ALLOCATABLE :: Atmosphere_K(:,:)
  TYPE(CRTM_Atmosphere_type), ALLOCATABLE :: Atmosphere_NAM_K(:,:)
  TYPE(CRTM_Atmosphere_type), ALLOCATABLE :: Atmosphere_GFS_K(:,:)
  TYPE(CRTM_Surface_type)   , ALLOCATABLE :: Surface_K(:,:)
  TYPE(CRTM_Surface_type)   , ALLOCATABLE :: Surface_NAM_K(:,:)
  TYPE(CRTM_Surface_type)   , ALLOCATABLE :: Surface_GFS_K(:,:)
  TYPE(CRTM_RTSolution_type), ALLOCATABLE :: RTSolution_K(:,:)
  TYPE(CRTM_RTSolution_type), ALLOCATABLE :: RTSolution_NAM_K(:,:)
  TYPE(CRTM_RTSolution_type), ALLOCATABLE :: RTSolution_GFS_K(:,:)
  ! ============================================================================

  !First, make sure the right number of inputs have been provided
  IF(COMMAND_ARGUMENT_COUNT().NE.1)THEN
     WRITE(*,*) TRIM(PROGRAM_NAME)//': ERROR, ONLY one command-line argument required, returning'
     STOP 1
  ENDIF
  CALL GET_COMMAND_ARGUMENT(1,Sensor_Id)   !read in the value

  ! Program header
  ! --------------
  CALL CRTM_Version( Version )
  CALL Program_Message( PROGRAM_NAME, &
    'Test program for the CRTM K-Matrix function using different vertical '//&
    'coordinates from the training set, under clear sky conditions.', &
    'CRTM Version: '//TRIM(Version) )

  ! Get sensor id from user
  ! -----------------------
  Sensor_Id = ADJUSTL(Sensor_Id)
  WRITE( *,'(//5x,"Running CRTM for ",a," sensor...")' ) TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)

  ! ============================================================================
  ! 2. **** INITIALIZE THE CRTM ****
  !
  ! 2a. Initialise the requested sensor
  ! -----------------------------------
  WRITE( *,'(/5x,"Initializing the CRTM...")' )
  Error_Status = CRTM_Init( (/Sensor_Id/), &
                            ChannelInfo, &
                            File_Path=COEFFICIENTS_PATH)
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error initializing CRTM'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF

  ! 2b. Determine the total number of channels
  !     for which the CRTM was initialized
  ! ------------------------------------------
  n_Channels = SUM(CRTM_ChannelInfo_n_Channels(ChannelInfo))
  ! ============================================================================

  ! ============================================================================
  ! 3. **** ALLOCATE STRUCTURE ARRAYS ****
  !
  ! 3a. Allocate the ARRAYS
  ! -----------------------
  ALLOCATE( RTSolution( n_Channels, N_PROFILES ), &
            RTSolution_NAM( n_Channels, N_PROFILES ), &
            RTSolution_GFS( n_Channels, N_PROFILES ), &
            Atmosphere_K( n_Channels, N_PROFILES ), &
            Atmosphere_NAM_K( n_Channels, N_PROFILES ), &
            Atmosphere_GFS_K( n_Channels, N_PROFILES ), &
            Surface_K( n_Channels, N_PROFILES ), &
            Surface_NAM_K( n_Channels, N_PROFILES ), &
            Surface_GFS_K( n_Channels, N_PROFILES ), &
            RTSolution_K( n_Channels, N_PROFILES ), &
            RTSolution_NAM_K( n_Channels, N_PROFILES ), &
            RTSolution_GFS_K( n_Channels, N_PROFILES ), &
            STAT = Allocate_Status )
  IF ( Allocate_Status /= 0 ) THEN
    Message = 'Error allocating structure arrays'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF

  ! 3b. Allocate the STRUCTURES
  ! ---------------------------

  ! ----------------------------
  ! The input FORWARD structures
  ! ----------------------------
  ! CRTM build test vertical coordinates
  CALL CRTM_Atmosphere_Create( Atm, N_LAYERS, N_ABSORBERS, N_CLOUDS, N_AEROSOLS )
  IF ( ANY(.NOT. CRTM_Atmosphere_Associated(Atm)) ) THEN
    Message = 'Error allocating CRTM Atmosphere structure'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! NAM build test vertical coordinates
  CALL CRTM_Atmosphere_Create( Atm_NAM, N_NAM_LAYERS, N_ABSORBERS, N_CLOUDS, N_AEROSOLS )
  IF ( ANY(.NOT. CRTM_Atmosphere_Associated(Atm)) ) THEN
    Message = 'Error allocating CRTM Atmosphere_NAM structure'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! GFS build test vertical coordinates
  CALL CRTM_Atmosphere_Create( Atm_GFS, N_GFS_LAYERS, N_ABSORBERS, N_CLOUDS, N_AEROSOLS )
  IF ( ANY(.NOT. CRTM_Atmosphere_Associated(Atm)) ) THEN
    Message = 'Error allocating CRTM Atmosphere_GFS structure'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! ------------------------------
  ! The output K-MATRIX structures
  ! ------------------------------
  ! CRTM output
  CALL CRTM_Atmosphere_Create( Atmosphere_K, N_LAYERS, N_ABSORBERS, N_CLOUDS, N_AEROSOLS )
  IF ( ANY(.NOT. CRTM_Atmosphere_Associated(Atmosphere_K)) ) THEN
    Message = 'Error allocating CRTM Atmosphere_K structure'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! NAM output
  CALL CRTM_Atmosphere_Create( Atmosphere_NAM_K, N_NAM_LAYERS, N_ABSORBERS, N_CLOUDS, N_AEROSOLS )
  IF ( ANY(.NOT. CRTM_Atmosphere_Associated(Atmosphere_K)) ) THEN
    Message = 'Error allocating CRTM Atmosphere_NAM_K structure'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! GFS output
  CALL CRTM_Atmosphere_Create( Atmosphere_GFS_K, N_GFS_LAYERS, N_ABSORBERS, N_CLOUDS, N_AEROSOLS )
  IF ( ANY(.NOT. CRTM_Atmosphere_Associated(Atmosphere_K)) ) THEN
    Message = 'Error allocating CRTM Atmosphere_GFS_K structure'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! ============================================================================

  ! ============================================================================
  ! 4. **** ASSIGN INPUT DATA ****
  !
  ! 4a. Atmosphere and Surface input
  ! --------------------------------
  CALL Load_Atm_Data()
  CALL Load_Sfc_Data()
  CALL Map_To_NCEP_Model_Coordinates()

  ! 4b. Geometry input
  ! ------------------
  ! All profiles are given the same value
  !  The Sensor_Scan_Angle is optional.
  CALL CRTM_Geometry_SetValue( Geometry, &
                               Sensor_Zenith_Angle = ZENITH_ANGLE, &
                               Sensor_Scan_Angle   = SCAN_ANGLE, &
                               Source_Zenith_Angle = SOURCE_ZENITH_ANGLE )
  ! ============================================================================

  ! ============================================================================
  ! 5. **** INITIALIZE THE K-MATRIX ARGUMENTS ****
  !
  ! 5a. Zero the K-matrix OUTPUT structures
  ! ---------------------------------------
  CALL CRTM_Atmosphere_Zero( Atmosphere_K )
  CALL CRTM_Atmosphere_Zero( Atmosphere_NAM_K )
  CALL CRTM_Atmosphere_Zero( Atmosphere_GFS_K )
  CALL CRTM_Surface_Zero( Surface_K )
  CALL CRTM_Surface_Zero( Surface_NAM_K )
  CALL CRTM_Surface_Zero( Surface_GFS_K )

  ! 5b. Inintialize the K-matrix INPUT so
  !     that the IR/MW results are dTb/dx
  !     and the visible results are dR/dx
  ! -------------------------------------
  DO l = 1, n_Channels
    IF ( ChannelInfo(1)%Sensor_Type == INFRARED_SENSOR .OR. &
         ChannelInfo(1)%Sensor_Type == MICROWAVE_SENSOR ) THEN
      RTSolution_K(l,:)%Radiance     = ZERO
      RTSolution_NAM_K(l,:)%Radiance = ZERO
      RTSolution_GFS_K(l,:)%Radiance = ZERO
      RTSolution_K(l,:)%Brightness_Temperature     = ONE
      RTSolution_NAM_K(l,:)%Brightness_Temperature = ONE
      RTSolution_GFS_K(l,:)%Brightness_Temperature = ONE
    ELSE
      RTSolution_K(l,:)%Radiance     = ONE
      RTSolution_NAM_K(l,:)%Radiance = ONE
      RTSolution_GFS_K(l,:)%Radiance = ONE
      RTSolution_K(l,:)%Brightness_Temperature     = ZERO
      RTSolution_NAM_K(l,:)%Brightness_Temperature = ZERO
      RTSolution_GFS_K(l,:)%Brightness_Temperature = ZERO
    END IF
  END DO
  ! ============================================================================

  ! ============================================================================
  ! 6. **** CALL THE CRTM K-Matrix MODEL ****
  !

  ! CRTM build test vertical resolution
  Error_Status = CRTM_K_Matrix( Atm         , &
                                Sfc         , &
                                RTSolution_K, &
                                Geometry    , &
                                ChannelInfo , &
                                Atmosphere_K, &
                                Surface_K   , &
                                RTSolution  , &
                                Options = Options )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error in CRTM K_Matrix Model (Build test resolution)'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF

  ! Regional vertical resolution
  Error_Status = CRTM_K_Matrix( Atm_NAM         , &
                                Sfc             , &
                                RTSolution_NAM_K, &
                                Geometry        , &
                                ChannelInfo     , &
                                Atmosphere_NAM_K, &
                                Surface_NAM_K   , &
                                RTSolution_NAM  , &
                                Options = Options )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error in CRTM K_Matrix Model (NAM resolution)'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF

  ! Global vertical resolution
  Error_Status = CRTM_K_Matrix( Atm_GFS         , &
                                Sfc             , &
                                RTSolution_GFS_K, &
                                Geometry        , &
                                ChannelInfo     , &
                                Atmosphere_GFS_K, &
                                Surface_GFS_K   , &
                                RTSolution_GFS  , &
                                Options = Options )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error in CRTM K_Matrix Model (GFS resolution)'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! ============================================================================

  ! ============================================================================
  ! 7. **** OUTPUT THE RESULTS TO SCREEN ****
  !
  DO m = 1, N_PROFILES
    WRITE( *,'(//7x,"Profile ",i0," output for ",a )') m, TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)
    DO l = 1, n_Channels
      WRITE( *, '(/5x,"Channel ",i0," results")') RTSolution(l,m)%Sensor_Channel
      ! FWD output
      WRITE( *, '(/3x,"FORWARD OUTPUT")')
      CALL CRTM_RTSolution_Inspect(RTSolution(l,m))
      CALL CRTM_RTSolution_Inspect(RTSolution_NAM(l,m))
      CALL CRTM_RTSolution_Inspect(RTSolution_GFS(l,m))
      ! K-MATRIX output
      WRITE( *, '(/3x,"K-MATRIX OUTPUT")')
      CALL CRTM_Surface_Inspect(Surface_K(l,m))
      CALL CRTM_Surface_Inspect(Surface_NAM_K(l,m))
      CALL CRTM_Surface_Inspect(Surface_GFS_K(l,m))
      CALL CRTM_Atmosphere_Inspect(Atmosphere_K(l,m))
      CALL CRTM_Atmosphere_Inspect(Atmosphere_NAM_K(l,m))
      CALL CRTM_Atmosphere_Inspect(Atmosphere_GFS_K(l,m))
    END DO
  END DO
  ! ============================================================================

  ! ============================================================================
  ! 9. **** COMPARE Atmosphere_K and Surface_K RESULTS TO SAVED VALUES ****
  !
  WRITE( *, '( /5x, "Comparing calculated results with saved ones..." )' )

  ! 9a. Create the output files if they do not exist
  ! ------------------------------------------------
  ! 9a.1 Atmosphere file
  ! ...Generate filename
  atmk_File = RESULTS_PATH//TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.Atmosphere.bin'
  atmk_NAM_File = RESULTS_PATH//TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.NAM.Atmosphere.bin'
  atmk_GFS_File = RESULTS_PATH//TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.GFS.Atmosphere.bin'

  ! Assign pressures for k-matrix plotting
  DO l = 1, n_Channels
    Atmosphere_NAM_K(l,1)%Pressure = Atm_NAM(1)%Pressure
    Atmosphere_GFS_K(l,1)%Pressure = Atm_GFS(1)%Pressure
    Atmosphere_NAM_K(l,2)%Pressure = Atm_NAM(2)%Pressure
    Atmosphere_GFS_K(l,2)%Pressure = Atm_GFS(2)%Pressure
  END DO
  ! ...Check if the files exist
  ! build test vertical resolution
  IF ( .NOT. File_Exists(atmk_File) ) THEN
    Message = 'Atmosphere_K save file does not exist. Creating...'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
    ! ...File not found, so write Atmosphere_K structure to file
    Error_Status = CRTM_Atmosphere_WriteFile( atmk_file, Atmosphere_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating Atmosphere_K save file'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
      STOP 1
    END IF
  END IF
  ! NAM vertical resolution
  IF ( .NOT. File_Exists(atmk_NAM_File) ) THEN
    Message = 'Atmosphere_NAM_K save file does not exist. Creating...'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
    ! ...File not found, so write Atmosphere_K structure to file
    Error_Status = CRTM_Atmosphere_WriteFile( atmk_NAM_file, Atmosphere_NAM_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating Atmosphere_NAM_K save file'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
      STOP 1
    END IF
  END IF
  ! GFS vertical resolution
  IF ( .NOT. File_Exists(atmk_GFS_File) ) THEN
    Message = 'Atmosphere_GFS_K save file does not exist. Creating...'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
    ! ...File not found, so write Atmosphere_K structure to file
    Error_Status = CRTM_Atmosphere_WriteFile( atmk_GFS_file, Atmosphere_GFS_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating Atmosphere_GFS_K save file'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
      STOP 1
    END IF
  END IF
  ! 9a.2 Surface file
  ! ...Generate filename
  sfck_File = RESULTS_PATH//TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.Surface.bin'
  sfck_NAM_File = RESULTS_PATH//TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.NAM.Surface.bin'
  sfck_GFS_File = RESULTS_PATH//TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.GFS.Surface.bin'
  ! ...Check if the file exists
  ! CRTM build
  IF ( .NOT. File_Exists(sfck_File) ) THEN
    Message = 'Surface_K save file does not exist. Creating...'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
    ! ...File not found, so write Surface_K structure to file
    Error_Status = CRTM_Surface_WriteFile( sfck_file, Surface_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating Surface_K save file'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
      STOP 1
    END IF
  END IF
  ! NAM results
  IF ( .NOT. File_Exists(sfck_NAM_File) ) THEN
    Message = 'Surface_NAM_K save file does not exist. Creating...'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
    ! ...File not found, so write Surface_K structure to file
    Error_Status = CRTM_Surface_WriteFile( sfck_NAM_file, Surface_NAM_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating Surface_NAM_K save file'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
      STOP 1
    END IF
  END IF
  ! GFS results
  IF ( .NOT. File_Exists(sfck_GFS_File) ) THEN
    Message = 'Surface_GFS_K save file does not exist. Creating...'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
    ! ...File not found, so write Surface_K structure to file
    Error_Status = CRTM_Surface_WriteFile( sfck_GFS_file, Surface_GFS_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating Surface_GFS_K save file'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
      STOP 1
    END IF
  END IF

  ! 9b. Inquire the saved files
  ! ---------------------------
  ! 9b.1 Atmosphere file
  ! build test atmosphere
  Error_Status = CRTM_Atmosphere_InquireFile( atmk_File, &
                                              n_Channels = n_la, &
                                              n_Profiles = n_ma )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error inquiring Atmosphere_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! NAM atmosphere
  Error_Status = CRTM_Atmosphere_InquireFile( atmk_NAM_File, &
                                              n_Channels = n_NAM_la, &
                                              n_Profiles = n_NAM_ma )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error inquiring Atmosphere_NAM_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! GFS atmosphere
  Error_Status = CRTM_Atmosphere_InquireFile( atmk_GFS_File, &
                                              n_Channels = n_GFS_la, &
                                              n_Profiles = n_GFS_ma )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error inquiring Atmosphere_GFS_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! 9b.2 Surface file
  ! build test
  Error_Status = CRTM_Surface_InquireFile( sfck_File, &
                                           n_Channels = n_ls, &
                                           n_Profiles = n_ms )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error inquiring Surface_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! NAM
  Error_Status = CRTM_Surface_InquireFile( sfck_NAM_File, &
                                           n_Channels = n_NAM_ls, &
                                           n_Profiles = n_NAM_ms )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error inquiring Surface_NAM_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! GFS
  Error_Status = CRTM_Surface_InquireFile( sfck_GFS_File, &
                                           n_Channels = n_GFS_ls, &
                                           n_Profiles = n_GFS_ms )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error inquiring Surface_GFS_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF

  ! 9c. Compare the dimensions
  ! --------------------------
  IF ( n_la /= n_Channels .OR. n_ma /= N_PROFILES .OR. &
       n_ls /= n_Channels .OR. n_ms /= N_PROFILES .OR. &
       n_NAM_la /= n_Channels .OR. n_NAM_ma /= N_PROFILES .OR. &
       n_NAM_ls /= n_Channels .OR. n_NAM_ms /= N_PROFILES .OR. &
       n_GFS_la /= n_Channels .OR. n_GFS_ma /= N_PROFILES .OR. &
       n_GFS_ls /= n_Channels .OR. n_GFS_ms /= N_PROFILES      ) THEN
    Message = 'Dimensions of saved data different from that calculated!'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF

  ! 9d. Read the saved data
  ! -----------------------
  ! 9d.1 Atmosphere file
  ! Build test atmosphere
  Error_Status = CRTM_Atmosphere_ReadFile( atmk_File, atm_k, Quiet=.TRUE. )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error reading Atmosphere_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! NAM atmosphere
  Error_Status = CRTM_Atmosphere_ReadFile( atmk_NAM_File, atm_NAM_k, Quiet=.TRUE. )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error reading Atmosphere_NAM_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! GFS atmosphere
  Error_Status = CRTM_Atmosphere_ReadFile( atmk_GFS_File, atm_GFS_k, Quiet=.TRUE. )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error reading Atmosphere_GFS_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! 9d.2 Surface file
  ! Build
  Error_Status = CRTM_Surface_ReadFile( sfck_File, sfc_k, Quiet=.TRUE. )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error reading Surface_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! NAM
  Error_Status = CRTM_Surface_ReadFile( sfck_NAM_File, sfc_NAM_k, Quiet=.TRUE. )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error reading Surface_NAM_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! GFS
  Error_Status = CRTM_Surface_ReadFile( sfck_GFS_File, sfc_GFS_k, Quiet=.TRUE. )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error reading Surface_GFS_K save file'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF

  ! 9e. Compare some Jacobians
  ! --------------------------
  ! 9e.1 Atmosphere
  ! Build test resolution
  IF ( ALL(CRTM_Atmosphere_Compare(Atmosphere_K, atm_k)) ) THEN
    Message = 'Atmosphere_K Jacobians are the same!'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
  ELSE
    Message = 'Atmosphere_K Jacobians are different!'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    ! Write the current Atmosphere_K results to file
    atmk_File = TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.Atmosphere.bin'
    Error_Status = CRTM_Atmosphere_WriteFile( atmk_file, Atmosphere_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating temporary Atmosphere_K save file for failed comparison'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    END IF
  END IF
  ! NAM resolution
  IF ( ALL(CRTM_Atmosphere_Compare(Atmosphere_NAM_K, atm_NAM_k)) ) THEN
    Message = 'Atmosphere_NAM_K Jacobians are the same!'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
  ELSE
    Message = 'Atmosphere_NAM_K Jacobians are different!'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    ! Write the current Atmosphere_NAM_K results to file
    atmk_NAM_File = TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.NAM.Atmosphere.bin'
    Error_Status = CRTM_Atmosphere_WriteFile( atmk_NAM_file, Atmosphere_NAM_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating temporary Atmosphere_NAM_K save file for failed comparison'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    END IF
  END IF
  ! GFS resolution
  IF ( ALL(CRTM_Atmosphere_Compare(Atmosphere_GFS_K, atm_GFS_k)) ) THEN
    Message = 'Atmosphere_GFS_K Jacobians are the same!'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
  ELSE
    Message = 'Atmosphere_GFS_K Jacobians are different!'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    ! Write the current Atmosphere_GFS_K results to file
    atmk_GFS_File = TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.GFS.Atmosphere.bin'
    Error_Status = CRTM_Atmosphere_WriteFile( atmk_GFS_file, Atmosphere_GFS_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating temporary Atmosphere_GFS_K save file for failed comparison'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    END IF
  END IF

  ! 9e.2 Surface
  ! Build
  IF ( ALL(CRTM_Surface_Compare(Surface_K, sfc_k, n_SigFig=5)) ) THEN
    Message = 'Surface_K Jacobians are the same!'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
  ELSE
    Message = 'Surface_K Jacobians are different!'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    ! Write the current Surface_K results to file
    sfck_File = TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.Surface.bin'
    Error_Status = CRTM_Surface_WriteFile( sfck_file, Surface_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating temporary Surface_K save file for failed comparison'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    END IF
  END IF
  ! NAM
  IF ( ALL(CRTM_Surface_Compare(Surface_NAM_K, sfc_NAM_k, n_SigFig=5)) ) THEN
    Message = 'Surface_NAM_K Jacobians are the same!'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
  ELSE
    Message = 'Surface_NAM_K Jacobians are different!'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    ! Write the current Surface_NAM_K results to file
    sfck_NAM_File = TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.NAM.Surface.bin'
    Error_Status = CRTM_Surface_WriteFile( sfck_NAM_file, Surface_NAM_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating temporary Surface_NAM_K save file for failed comparison'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    END IF
  END IF
  ! GFS
  IF ( ALL(CRTM_Surface_Compare(Surface_GFS_K, sfc_GFS_k, n_SigFig=5)) ) THEN
    Message = 'Surface_GFS_K Jacobians are the same!'
    CALL Display_Message( PROGRAM_NAME, Message, INFORMATION )
  ELSE
    Message = 'Surface_GFS_K Jacobians are different!'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    ! Write the current Surface_GFS_K results to file
    sfck_GFS_File = TRIM(PROGRAM_NAME)//'_'//TRIM(Sensor_Id)//'.GFS.Surface.bin'
    Error_Status = CRTM_Surface_WriteFile( sfck_GFS_file, Surface_GFS_K, Quiet=.TRUE. )
    IF ( Error_Status /= SUCCESS ) THEN
      Message = 'Error creating temporary Surface_GFS_K save file for failed comparison'
      CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    END IF
  END IF
  ! ============================================================================

  ! ============================================================================
  ! 8. **** DESTROY THE CRTM ****
  !
  WRITE( *, '( /5x, "Destroying the CRTM..." )' )
  Error_Status = CRTM_Destroy( ChannelInfo )
  IF ( Error_Status /= SUCCESS ) THEN
    Message = 'Error destroying CRTM'
    CALL Display_Message( PROGRAM_NAME, Message, FAILURE )
    STOP 1
  END IF
  ! ============================================================================

  ! ============================================================================
  ! 10. **** CLEAN UP ****
  !
  ! 10a. Deallocate the structures
  ! ------------------------------
  CALL CRTM_Atmosphere_Destroy(atm_K)
  CALL CRTM_Atmosphere_Destroy(atm_NAM_K)
  CALL CRTM_Atmosphere_Destroy(atm_GFS_K)
  CALL CRTM_Atmosphere_Destroy(Atmosphere_K)
  CALL CRTM_Atmosphere_Destroy(Atmosphere_NAM_K)
  CALL CRTM_Atmosphere_Destroy(Atmosphere_GFS_K)
  CALL CRTM_Atmosphere_Destroy(Atm)
  CALL CRTM_Atmosphere_Destroy(Atm_NAM)
  CALL CRTM_Atmosphere_Destroy(Atm_GFS)

  ! 10b. Deallocate the arrays
  ! --------------------------
  DEALLOCATE(RTSolution, RTSolution_K, &
             Surface_K, Atmosphere_K, &
             sfc_K, atm_K, &
             RTSolution_NAM, RTSolution_NAM_K, &
             Surface_NAM_K, Atmosphere_NAM_K, &
             sfc_NAM_K, atm_NAM_K, &
             RTSolution_GFS, RTSolution_GFS_K, &
             Surface_GFS_K, Atmosphere_GFS_K, &
             sfc_GFS_K, atm_GFS_K, &
             STAT = Allocate_Status)
  ! ============================================================================

  ! Signal the completion of the program. It is not a necessary step for running CRTM.

CONTAINS

  INCLUDE 'Load_Atm_Data.inc'
  INCLUDE 'Load_Sfc_Data.inc'
  INCLUDE 'Map_To_NCEP_Model_Coordinates.inc'

END PROGRAM test_VerticalCoordinates


!-----------------------------------------------------------------------
! Fortran2003 interface to CUDA Library for Skeleton 2D Electrostatic
! GPU-MPI PIC Code */
! written by Viktor K. Decyk, UCLA
      module gpuppush2_c
      use iso_c_binding
      implicit none
!
      interface
         subroutine cgpuppgppush2l(g_ppart,g_fxy,g_kpic,noff,nyp,qbm,dt,&
     &g_ek,nx,ny,mx,my,idimp,nppmx,nxv,nypmx,mx1,mxyp1,ipbc)            &
     &bind(C,name='cgpuppgppush2l')
         use iso_c_binding
         implicit none
         integer(c_int), value :: nx, ny, mx, my, idimp, nppmx, nxv
         integer(c_int), value :: nypmx, mx1, mxyp1, ipbc
         integer(c_int), value :: noff, nyp
         real(c_float), value :: qbm, dt
         type (c_ptr), value :: g_ppart, g_fxy, g_kpic, g_ek
         end subroutine
      end interface
!
      interface
         subroutine cgpu2ppgppost2l(g_ppart,g_q,g_kpic,noff,qm,idimp,   &
     &nppmx,mx,my,nxv,nypmx,mx1,mxyp1) bind(C,name='cgpu2ppgppost2l')
         use iso_c_binding
         implicit none
         integer(c_int), value :: idimp, nppmx, mx, my, nxv, nypmx, mx1
         integer(c_int), value :: mxyp1
         integer(c_int), value :: noff
         real(c_float), value :: qm
         type (c_ptr), value :: g_ppart, g_q, g_kpic
         end subroutine
      end interface
!
      interface
         subroutine cgpuppcaguard2xl(g_qc,g_scs,g_q,nyp,nx,nxe,nypmx,   &
     &nxvh,kypd) bind(C,name='cgpuppcaguard2xl')
         use iso_c_binding
         implicit none
         integer(c_int), value :: nx, nxe, nypmx, nxvh, kypd
         integer(c_int), value :: nyp
         type (c_ptr), value :: g_qc, g_scs, g_q
         end subroutine
      end interface
!
      interface
         subroutine cgpuppcaguard2yl(g_qc,g_scr,nx,nxvh,kypd)           &
     & bind(C,name='cgpuppcaguard2yl')
         use iso_c_binding
         implicit none
         integer(c_int), value :: nx, nxvh, kypd
         type (c_ptr), value :: g_qc, g_scr
         end subroutine
      end interface
!
      interface
         subroutine cgpuppccguard2xl(g_fxyc,g_scs,g_fxy,nyp,nx,nxe,nypmx&
     &,nxvh,kypd) bind(C,name='cgpuppccguard2xl')
         use iso_c_binding
         implicit none
         integer(c_int), value :: nx, nxe, nypmx, nxvh, kypd
         integer(c_int), value :: nyp
         type (c_ptr), value :: g_fxyc, g_scs, g_fxy
         end subroutine
      end interface
!
      interface
         subroutine cgpuppccguard2yl(g_fxy,g_scr,nyp,nx,nxe,nxvh,nypmx) &
     &bind(C,name='cgpuppccguard2yl')
         use iso_c_binding
         implicit none
         integer(c_int), value :: nx, nxe, nxvh, nypmx
         integer(c_int), value :: nyp
         type (c_ptr), value :: g_fxy, g_scr
         end subroutine
      end interface
!
      interface
         subroutine cgpupppord2la(g_ppart,g_ppbuff,g_sbufl,g_sbufr,     &
     &g_kpic,g_ncl,g_ihole,g_ncll,g_nclr,noff,nyp,idimp,nppmx,nx,ny,mx, &
     &my,mx1,myp1,npbmx,ntmax,nbmax,g_irc) bind(C,name='cgpupppord2la')
         use iso_c_binding
         implicit none
         integer(c_int), value :: idimp, nppmx, nx, ny, mx, my, mx1
         integer(c_int), value ::myp1, npbmx, ntmax, nbmax
         integer(c_int), value:: noff, nyp
         type (c_ptr), value :: g_ppart, g_ppbuff, g_sbufl, g_sbufr
         type (c_ptr), value :: g_kpic, g_ncl, g_ihole, g_ncll, g_nclr
         type (c_ptr), value :: g_irc
         end subroutine
      end interface
!
      interface
         subroutine cgpupppord2lb(g_ppart,g_ppbuff,g_rbufl,g_rbufr,     &
     &g_kpic,g_ncl,g_ihole,g_mcll,g_mclr,idimp,nppmx,mx1,myp1,npbmx,    &
     &ntmax,nbmax,g_irc) bind(C,name='cgpupppord2lb')
         use iso_c_binding
         implicit none
         integer(c_int), value :: idimp, nppmx, mx1, myp1, npbmx, ntmax
         integer(c_int), value :: nbmax
         type (c_ptr), value :: g_ppart, g_ppbuff, g_rbufl, g_rbufr
         type (c_ptr), value :: g_kpic, g_ncl, g_ihole, g_mcll, g_mclr
         type (c_ptr), value :: g_irc
         end subroutine
      end interface
!
      interface
         subroutine cgpuppois22t(g_qt, g_fxyt,g_ffct,g_we,nx,ny,kstrt,  &
     &nyv,kxp1,nyhd) bind(C,name='cgpuppois22t')
         use iso_c_binding
         implicit none
         integer(c_int), value :: nx, ny, kstrt, nyv, kxp1, nyhd
         type (c_ptr), value :: g_qt, g_fxyt, g_ffct, g_we
         end subroutine
      end interface
!
      interface
         subroutine cgpuwppfft2rcsx(g_f,g_bsm,isign,g_mixup,g_sct,indx, &
     &indy,kstrt,nvp,kxp1,kyp,nxhd,kypd,nxhyd,nxyhd)                    &
     &bind(C,name='cgpuwppfft2rcsx')
         use iso_c_binding
         implicit none
         integer(c_int), value :: isign, indx, indy, kstrt, nvp, kxp1
         integer(c_int), value :: kyp, nxhd, kypd, nxhyd, nxyhd
         type (c_ptr), value :: g_f, g_bsm, g_mixup, g_sct
         end subroutine
      end interface
!
      interface
         subroutine cgpuwppfft2rcsy(g_g,g_brm,isign,g_mixup,g_sct,indx, &
     &indy,kstrt,nvp,kxp1,kyp,nyd,nxhyd,nxyhd)                          &
     &bind(C,name='cgpuwppfft2rcsy')
         use iso_c_binding
         implicit none
         integer(c_int), value :: isign, indx, indy, kstrt, nvp, kxp1
         integer(c_int), value :: kyp, nyd, nxhyd, nxyhd
         type (c_ptr), value :: g_g, g_brm, g_mixup, g_sct
         end subroutine
      end interface
!
      interface
         subroutine cgpuwppfft2rcsxn(g_fn,g_bsm,isign,g_mixup,g_sct,indx&
     &,indy,ndim,kstrt,nvp,kxp1,kyp,nxhd,kypd,nxhyd,nxyhd)              &
     &bind(C,name='cgpuwppfft2rcsxn')
         use iso_c_binding
         implicit none
         integer(c_int), value :: isign, indx, indy, ndim, kstrt, nvp
         integer(c_int), value :: kxp1, kyp, nxhd, kypd, nxhyd, nxyhd
         type (c_ptr), value :: g_fn, g_bsm, g_mixup, g_sct
         end subroutine
      end interface
!
      interface
         subroutine cgpuwppfft2rcsyn(g_gn,g_brm,isign,g_mixup,g_sct,indx&
     &,indy,ndim,kstrt,nvp,kxp1,kyp,nyd,nxhyd,nxyhd)                    &
     &bind(C,name='cgpuwppfft2rcsyn')
         use iso_c_binding
         implicit none
         integer(c_int), value :: isign, indx, indy, ndim, kstrt, nvp
         integer(c_int), value :: kxp1, kyp, nyd, nxhyd, nxyhd
         type (c_ptr), value :: g_gn, g_brm, g_mixup, g_sct
         end subroutine
      end interface
!
      interface
         subroutine cgpuppltpose(g_f,g_g,nx,ny,kxp,kyp,kstrt,nxv,nyv)   &
     &bind(C,name='cgpuppltpose')
         use iso_c_binding
         implicit none
         integer(c_int), value:: nx, ny, kxp, kyp, kstrt, nxv, nyv
         type (c_ptr), value :: g_f, g_g
         end subroutine
      end interface
!
      interface
         subroutine cgpuppltposen(g_fn,g_gn,nx,ny,kxp,kyp,kstrt,ndim,nxv&
     &,nyv) bind(C,name='cgpuppltposen')
         use iso_c_binding
         implicit none
         integer(c_int), value :: nx, ny, kxp, kyp, kstrt, ndim, nxv
         integer(c_int), value :: nyv
         type (c_ptr), value :: g_fn, g_gn
         end subroutine
      end interface
!
      interface
         subroutine cgpusum2(g_a,g_sa,nx) bind(C,name='cgpusum2')
         use iso_c_binding
         implicit none
         integer(c_int), value :: nx
         type (c_ptr), value :: g_a, g_sa
         end subroutine
      end interface
!
      end module


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

C $Log: setup.f,v $
C Revision 1.2  2009/03/25 12:36:47  gdsjaar
C Add copyright and license notice to all files.
C Permission to assert copyright has been granted; blot is now open source, BSD
C
C Revision 1.1  1994/04/07 20:11:45  gdsjaar
C Initial checkin of ACCESS/graphics/blotII2
C
c Revision 1.2  1990/12/14  08:57:16  gdsjaar
c Added RCS Id and Log to all files
c
C=======================================================================
      SUBROUTINE SETUP (MSHDEF, ZMMESH)
C=======================================================================

C   --*** SETUP *** (MESH) Setup for plot set
C   --   Written by Amy Gilkey - revised 05/26/88
C   --   D. P. Flanagan, 07/27/82
C   --
C   --SETUP sets graphics parameters common to the plot sequence.  It
C   --computes the display area and window for each view.  It also computes
C   --and sets the axis lengths and limits (with "nice" tick intervals).
C   --The only information that is returned about the axis is the
C   --starting locations and the label size factor (through COMMON).
C   --
C   --Parameters:
C   --   MSHDEF - IN - the display modes for all views (none/defined)
C   --      (as in /MSHOPT/)
C   --   ZMMESH - IN - the zoomed mesh coordinates
C   --
C   --Common Variables:
C   --   Uses XISSYM, YISSYM, XAXSYM, YAXSYM, LFTSYM, BOTSYM of /VIEWS/
C   --   Uses ZMMESH of /MSHLIM/
C   --   Uses DVIEW0 of /LAYOUT/
C   --   Sets DVIEW, WVIEW of /LAYOUT/
C   --   Uses DTW, VWSCL of /DEVDAT/

      PARAMETER (KLFT=1, KRGT=2, KBOT=3, KTOP=4, KNEA=5, KFAR=6)

      COMMON /VIEWS/  MULTIM,
     &   XISSYM, YISSYM, XAXSYM, YAXSYM, LFTSYM, BOTSYM
      LOGICAL MULTIM, XISSYM, YISSYM, LFTSYM, BOTSYM
      COMMON /LAYOUT/ CHLSIZ, DBORD0(KTOP), DVIEW0(KTOP)
      COMMON /LAYOUD/ DVIEW(KTOP,4), WVIEW(KTOP,4)
      COMMON /DEVDAT/ DTW, VWSCL

      CHARACTER*(*) MSHDEF(4)
      REAL ZMMESH(KTOP)

      INTEGER NDEFVW, IXVW
      LOGICAL RGTVW, TOPVW
      LOGICAL XISDIV, YISDIV

      RGTVW(I) = (I .EQ. 2) .OR. (I .EQ. 4)
      TOPVW(I) = (I .EQ. 1) .OR. (I .EQ. 2)

      XISDIV = (MSHDEF(1) .NE. 'NONE')
      YISDIV = (MSHDEF(4) .NE. 'NONE')

C   --WXRNG and WYRNG are the window limits for a single view
      WXRNG = ZMMESH(KRGT) - ZMMESH(KLFT)
      WYRNG = ZMMESH(KTOP) - ZMMESH(KBOT)

C   --Set view device boundaries

      IF (XISDIV .EQV. YISDIV) THEN
         RAT = WXRNG / WYRNG
      ELSE IF (XISDIV) THEN
         RAT = (2 * WXRNG) / WYRNG
      ELSE IF (YISDIV) THEN
         RAT = WXRNG / (2 * WYRNG)
      END IF

C   --DXRNG2 and DYRNG2 are the device limits for all defined views / 2
      DXRNG2 = 0.5 * (DVIEW0(KRGT) - DVIEW0(KLFT))
      DYRNG2 = 0.5 * (DVIEW0(KTOP) - DVIEW0(KBOT))
      IF (RAT .LT. 0.99) THEN
         DXRNG2 = DXRNG2 * RAT
      ELSE IF (RAT .GT. 1.01) THEN
         DYRNG2 = DYRNG2 / RAT
      END IF

      DXMID = 0.5 * (DVIEW0(KRGT) + DVIEW0(KLFT))
      DYMID = 0.5 * (DVIEW0(KTOP) + DVIEW0(KBOT))
      DO 100 IVW = 1, NDEFVW (.TRUE.)
         IVIEW = IXVW (.TRUE., IVW)
         IF (XISDIV) THEN
            IF (RGTVW(IVIEW)) THEN
               DVIEW(KLFT,IVIEW) = DXMID
               DVIEW(KRGT,IVIEW) = DXMID + DXRNG2
            ELSE
               DVIEW(KLFT,IVIEW) = DXMID - DXRNG2
               DVIEW(KRGT,IVIEW) = DXMID
            END IF
         ELSE
            DVIEW(KLFT,IVIEW) = DXMID - DXRNG2
            DVIEW(KRGT,IVIEW) = DXMID + DXRNG2
         END IF
         IF (YISDIV) THEN
            IF (TOPVW(IVIEW)) THEN
               DVIEW(KBOT,IVIEW) = DYMID
               DVIEW(KTOP,IVIEW) = DYMID + DYRNG2
            ELSE
               DVIEW(KBOT,IVIEW) = DYMID - DYRNG2
               DVIEW(KTOP,IVIEW) = DYMID
            END IF
         ELSE
            DVIEW(KBOT,IVIEW) = DYMID - DYRNG2
            DVIEW(KTOP,IVIEW) = DYMID + DYRNG2
         END IF
  100 CONTINUE

C   --Set window limits

      IF (XISSYM) THEN
         IF (LFTSYM) THEN
            WLFT = XAXSYM
            WRGT = XAXSYM + WXRNG
         ELSE
            WLFT = XAXSYM
            WRGT = XAXSYM - WXRNG
         END IF
      ELSE
         WLFT = ZMMESH(KLFT)
         WRGT = ZMMESH(KRGT)
      END IF
      IF (YISSYM) THEN
         IF (BOTSYM) THEN
            WBOT = YAXSYM
            WTOP = YAXSYM + WYRNG
         ELSE
            WBOT = YAXSYM
            WTOP = YAXSYM - WYRNG
         END IF
      ELSE
         WBOT = ZMMESH(KBOT)
         WTOP = ZMMESH(KTOP)
      END IF

C   --Set view window boundaries

      DO 110 IVW = 1, NDEFVW (.TRUE.)
         IVIEW = IXVW (.TRUE., IVW)
         IF (XISSYM .AND. (.NOT. RGTVW(IVIEW))) THEN
            WVIEW(KLFT,IVIEW) = WRGT
            WVIEW(KRGT,IVIEW) = WLFT
         ELSE
            WVIEW(KLFT,IVIEW) = WLFT
            WVIEW(KRGT,IVIEW) = WRGT
         END IF
         IF (YISSYM .AND. (.NOT. TOPVW(IVIEW))) THEN
            WVIEW(KBOT,IVIEW) = WTOP
            WVIEW(KTOP,IVIEW) = WBOT
         ELSE
            WVIEW(KBOT,IVIEW) = WBOT
            WVIEW(KTOP,IVIEW) = WTOP
         END IF
  110 CONTINUE

C   --Set window to device units ratio

      DTW = MIN (ABS (WRGT - WLFT), ABS (WTOP - WBOT))
     &   / (DVIEW0(KRGT) - DVIEW0(KLFT))

      IF (XISDIV .OR. YISDIV) THEN
         VWSCL = 0.5
      ELSE
         VWSCL = 1.0
      END IF

      RETURN
      END


      SUBROUTINE C01005 (USEPRM)

C  C01005 tests the handling of error number 5: function requires
C  state (PHOP,*,STOP,*), when PHIGS is closed.

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /ERRINF/ ERRCOM,FUNCOM,FILCOM, ERNMSW, EXPSIZ,EXPERR,
     1                USRERR, ERRSAV,      FUNSAV,      FILSAV,
     2                EFCNT, EFID
      INTEGER         ERRCOM,FUNCOM,FILCOM, ERNMSW, EXPSIZ,EXPERR(10),
     1                USRERR, ERRSAV(200), FUNSAV(200), FILSAV(200),
     2                EFCNT, EFID(100)
      COMMON /ERRCHR/ CURCON,     ERRSRS,    ERRMRK,    ERFLNM,
     1                CONTAB
      CHARACTER       CURCON*200, ERRSRS*40, ERRMRK*20, ERFLNM*80,
     1                CONTAB(40)*150

C   aspect identifier
      INTEGER      PLN
      PARAMETER   (PLN = 0)
C   aspect source
      INTEGER      PINDIV
      PARAMETER   (PINDIV = 1)
C   composition  type
      INTEGER      PCREPL
      PARAMETER   (PCREPL = 2)

      INTEGER USEPRM, N, NPL, IXA(2), ISIZ, NAMEST(1)
      REAL    PXA(10), PYA(10), PZA(10), XFRMT(3,3)

      LOGICAL   STREQ

      CALL IFPHCL (USEPRM)
      CALL SETVS ('5', EXPERR,EXPSIZ)
      ERRSRS = '5'

      N = 2
      PXA(1) = 0.
      PXA(2) = 0.5
      PYA(1) = 0.
      PYA(2) = 0.5
      PZA(1) = 0.
      PZA(2) = 0.5

      CALL RPM (N, PXA, PYA)
      CALL TSTIGN (STREQ('CCCC'))

      CALL RATR (0., 0., 0.1, 0.1, 'annotation-text')

      NPL = 1
      IXA(1) = 4
      CALL SETRVS ('0.,0.4,0.4,0.',PXA,ISIZ)
      CALL SETRVS ('0.,0.,0.4,0.4',PYA,ISIZ)
      CALL RFAS (NPL, IXA, PXA, PYA)

      CALL RSII (1)

      CALL RSMKSC (1.0)

      CALL RSTXFN (1)

      CALL RSANS (1)

      CALL RSPARF (0., 0.)

      CALL RRES (1, NAMEST)

      CALL RSHRID (33)

      CALL IDMAT (3, XFRMT)
      CALL RSGMT (XFRMT)

      CALL RCLST

      CALL RLB (100)

      CALL RSEP (200)
      CALL TSTIGN (STREQ('CCCC'))

      CALL ENDERR

      END