!
! Select_TauProfile
!
! Program to select the combination of LBL-generated transmittance components
! that minimises the occurrance of effective transmittance profiles that
! contain negative optical depths.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 17-Dec-2007
!                       paul.vandelst@noaa.gov
!

PROGRAM Select_TauProfile

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module usage
  USE Type_Kinds               , ONLY: fp
  USE File_Utility             , ONLY: File_Exists
  USE Binary_File_Utility      , ONLY: Open_Binary_File
  USE Message_Handler          , ONLY: SUCCESS, FAILURE, WARNING, &
                                       Display_Message, Program_Message
  USE SensorInfo_Define        , ONLY: SensorInfo_type, &
                                       Destroy_SensorInfo
  USE SensorInfo_LinkedList    , ONLY: SensorInfo_List_type, &
                                       Count_SensorInfo_Nodes, &
                                       GetFrom_SensorInfo_List, &
                                       Destroy_SensorInfo_List
  USE SensorInfo_IO            , ONLY: Read_SensorInfo
  USE TauProfile_Define        , ONLY: TauProfile_type
  USE TauProfile_netCDF_IO     , ONLY: Modify_TauProfile_GAtts, &
                                       Create_TauProfile_netCDF, &
                                       Inquire_TauProfile_netCDF, &
                                       Read_TauProfile_netCDF   , &
                                       Write_TauPRofile_netCDF
  USE Tau_Production_Parameters, ONLY: N_LAYERS             , &
                                       N_DIRECTIONS         , &
                                       UPWELLING_DIRECTION  , &
                                       DOWNWELLING_DIRECTION, &
                                       DIRECTION_NAME       , &
                                       N_PROFILE_SETS       , &
                                       PROFILE_SET_ID_TAG   , &
                                       LEVEL_PRESSURE
  USE Tau_Production_Utility   , ONLY: Create_Signal_File
  USE AtmProfile_Define        , ONLY: AtmProfile_type   , &
                                       Destroy_AtmProfile
  USE AtmProfile_netCDF_IO     , ONLY: Read_AtmProfile_netCDF
  USE SpcCoeff_Define          , ONLY: SpcCoeff_type   , &
                                       Destroy_SpcCoeff
  USE SpcCoeff_netCDF_IO       , ONLY: Read_SpcCoeff_netCDF
  USE Sensor_Planck_Functions  , ONLY: Sensor_Radiance, &
                                       Sensor_Temperature
  ! Disable implicit typing
  IMPLICIT NONE

  ! ----------
  ! Parameters
  ! ----------
  CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'Select_TauProfile'
  CHARACTER(*), PARAMETER :: PROGRAM_RCS_ID = &
  ! Keyword set value
  INTEGER, PARAMETER :: SET = 1
  ! Literal constants
  REAL(fp), PARAMETER :: ZERO = 0.0_fp
  REAL(fp), PARAMETER :: ONE  = 1.0_fp

  INTEGER, PARAMETER :: WLO_IDX =  1  ! H2O lines only, no continua
  INTEGER, PARAMETER :: ALL_IDX = 10  ! First 7 molecules with continua
  INTEGER, PARAMETER :: WVO_IDX = 11  ! H2O and O3 only with continua
  INTEGER, PARAMETER :: WET_IDX = 12  ! H2O lines and continua
  INTEGER, PARAMETER :: DRY_IDX = 13  ! Dry gases (no H2O and O3) and continua
  INTEGER, PARAMETER :: OZO_IDX = 14  ! O3 lines and continua
  INTEGER, PARAMETER :: WCO_IDX = 15  ! H2O continua only, no line absorption
  INTEGER, PARAMETER :: DOZ_IDX = 16  ! Dry and O3 only with continua
  INTEGER, PARAMETER :: WVD_IDX = 17  ! H2O and Dry with continua
  ! "effective" transmittances
  INTEGER, PARAMETER :: EFF_WET_IDX = WET_IDX + 100
  INTEGER, PARAMETER :: EFF_DRY_IDX = DRY_IDX + 100
  INTEGER, PARAMETER :: EFF_OZO_IDX = OZO_IDX + 100

  ! Definition of derived tau "sets" (the j1 value)
  INTEGER     , PARAMETER :: N_DERIVED = 3
  INTEGER     , PARAMETER :: WVO_DERIVED = 1
  INTEGER     , PARAMETER :: DOZ_DERIVED = 2
  INTEGER     , PARAMETER :: WVD_DERIVED = 3
  CHARACTER(*), PARAMETER :: DERIVED_NAME(N_DERIVED) = (/'WVO', 'DOZ', 'WVD'/)

  ! Definition of derived tau "subsets" (the j2 value)
  INTEGER     , PARAMETER :: N_DERIVED_SETS = 2
  CHARACTER(*), PARAMETER :: DERIVED_SET_NAME(N_DERIVED_SETS) = (/'_1', '_2'/)

  ! Number of which transmittances to read
  INTEGER, PARAMETER :: N_READ_IDX = 4
  INTEGER, PARAMETER :: WVO_DERIVED_IDX(N_READ_IDX) = (/ALL_IDX, WVO_IDX, WET_IDX, OZO_IDX/)
  INTEGER, PARAMETER :: DOZ_DERIVED_IDX(N_READ_IDX) = (/ALL_IDX, DOZ_IDX, DRY_IDX, OZO_IDX/)
  INTEGER, PARAMETER :: WVD_DERIVED_IDX(N_READ_IDX) = (/ALL_IDX, WVD_IDX, WET_IDX, DRY_IDX/)

  ! ---------
  ! Variables
  ! ---------
  CHARACTER(256)  :: Message
  CHARACTER(256)  :: ID_Tag
  CHARACTER(5000) :: History
  CHARACTER(5000) :: Comment
  CHARACTER(256)  :: AtmProfile_Filename
  CHARACTER(256)  :: SensorInfo_Filename
  CHARACTER(256)  :: TauProfile_Filename, Out_TauProfile_Filename(N_DERIVED_SETS,N_DERIVED)
  CHARACTER(256)  :: Signal_Filename
  CHARACTER(256)  :: SpcCoeff_Filename
  CHARACTER(256)  :: dTb_Filename
  INTEGER :: dTb_FileID
  INTEGER :: IO_Status
  INTEGER :: Error_Status
  INTEGER :: Allocate_Status
  INTEGER :: iDir, iProfile_Set
  INTEGER :: Release, Version
  INTEGER :: l, n_l ! n_Channels
  INTEGER :: i, n_i ! n_Angles
  INTEGER :: m, n_m ! n_Profiles
  INTEGER :: j, n_j ! n_Molecule_Sets
  INTEGER :: j1, j2
  INTEGER :: n, n_Sensors
  INTEGER :: Tau_Idx(N_READ_IDX)
  INTEGER :: AVG_Tau_Combo(2), RMS_Tau_Combo(2)
  INTEGER , ALLOCATABLE :: Channels(:)
  REAL(fp), ALLOCATABLE :: Angles(:)
  INTEGER , ALLOCATABLE :: Profiles(:)
  REAL(fp), TARGET  :: Tau_ALL(N_LAYERS)
  REAL(fp), TARGET  :: Tau_WVO(N_LAYERS), Tau_DOZ(N_LAYERS), Tau_WVD(N_LAYERS)
  REAL(fp), TARGET  :: Tau_WET(N_LAYERS), Tau_DRY(N_LAYERS), Tau_OZO(N_LAYERS)
  REAL(fp), POINTER :: Tau(:) => NULL()
  REAL(fp) :: Tau_EffWET(N_LAYERS), Tau_EffDRY(N_LAYERS), Tau_EffOZO(N_LAYERS)
  REAL(fp) :: Tau_EffALL(N_LAYERS)
  REAL(fp) :: Tb_All, Tb_EffALL, dTb
  REAL(fp), ALLOCATABLE :: delta_Tb(:,:,:,:)
  TYPE(AtmProfile_type)      :: Atm
  TYPE(SensorInfo_type)      :: SensorInfo
  TYPE(SensorInfo_List_type) :: SensorInfo_List
  TYPE(SpcCoeff_type) :: SpcCoeff

  ! Output header
  ! -------------
  CALL Program_Message( PROGRAM_NAME, &
                        'Program to select the combination of LBL-generated transmittance '//&
                        'components that minimises the occurrance of effective transmittance'//&
                        'profiles that contain negative optical depths.', &
                        '$Revision$' )

  ! Get user input
  ! --------------
  ! The profile set being processed
  WRITE(*, FMT='(/5x,"Select the DEPENDENT PROFILE SET")')
  DO i = 1, N_PROFILE_SETS
    WRITE(*,FMT='(10x,i2,") ",a," profile set")') i, TRIM(PROFILE_SET_ID_TAG(i))
  END DO
  WRITE(*,FMT='(5x,"Enter choice: ")',ADVANCE='NO')
  READ(*,FMT='(i1)',IOSTAT=IO_Status ) iProfile_Set
  IF ( IO_Status /= 0 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Invalid DEPENDENT PROFILE SET identifier input.', &
                          FAILURE )
    STOP
  END IF
  IF ( iProfile_Set < 1 .OR. iProfile_Set > N_PROFILE_SETS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Invalid DEPENDENT PROFILE SET identifier value.', &
                          FAILURE )
    STOP
  ENDIF

  ! The SensorInfo filename and data
  WRITE( *,FMT='(/5x,"Enter a SensorInfo filename: ")',ADVANCE='NO' )
  READ( *,FMT='(a)' ) SensorInfo_Filename
  SensorInfo_Filename = ADJUSTL(SensorInfo_Filename)

  Error_Status = Read_SensorInfo( SensorInfo_Filename, &
                                  SensorInfo_List    , &
                                  Quiet=SET            )
  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error reading SensorInfo file '//&
                          TRIM(SensorInfo_Filename), &
                          FAILURE )
    STOP
  END IF

  n_Sensors = Count_SensorInfo_Nodes( SensorInfo_List )
  IF ( n_Sensors < 1 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'SensorInfo_List is empty.', &
                          FAILURE )
    STOP
  END IF

  ! The calculation direction
  WRITE( *, FMT='(/5x,"Select atmospheric path")' )
  DO i = 1, N_DIRECTIONS
    WRITE( *,FMT='(10x,i1,") ",a)' ) i, TRIM(DIRECTION_NAME(i))
  END DO
  WRITE( *,FMT='(5x,"Enter choice: ")',ADVANCE='NO' )
  READ( *,FMT='(i1)',IOSTAT=IO_Status ) iDir
  IF ( IO_Status /= 0 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Invalid ATMOSPHERIC PATH identifier input.', &
                          FAILURE )
    STOP
  END IF
  IF ( iDir /= UPWELLING_DIRECTION   .AND. &
       iDir /= DOWNWELLING_DIRECTION       ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Invalid ATMOSPERIC PATH identifier value.', &
                          FAILURE )
    STOP
  ENDIF

  ! Read the required AtmProfile data file
  ! --------------------------------------
  AtmProfile_Filename = TRIM(PROFILE_SET_ID_TAG(iProfile_Set))//'.AtmProfile.nc'
  Error_Status = Read_AtmProfile_netCDF( AtmProfile_Filename, Atm )
  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error reading netCDF AtmProfile file '//&
                          TRIM(AtmProfile_Filename)//'.', &
                          Error_Status )
    STOP
  END IF

  ! Begin the main sensor loop
  ! ---------------------------
  Sensor_Loop: DO n = 1, n_Sensors

    ! Get the current SensorInfo data from the list
    ! ---------------------------------------------
    Error_Status = GetFrom_SensorInfo_List( SensorInfo_List, &
                                            n, &
                                            SensorInfo )
    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( Message,'("Error retrieving SensorInfo data for sensor # ",i0)' ) n
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM(Message), &
                            FAILURE )
      STOP
    END IF

    ! Only operate on sensors for which data is available
    ! ---------------------------------------------------
    SpcCoeff_Filename = TRIM(SensorInfo%Sensor_ID)//'.SpcCoeff.nc'
    TauProfile_Filename = TRIM(DIRECTION_NAME(iDir))//'.'//&
                          TRIM(SensorInfo%Sensor_ID)//'.TauProfile.nc'

    ! Cycle loop if no data
    IF ( (.NOT. File_Exists( TauProfile_Filename )) .OR. &
         (.NOT. File_Exists( SpcCoeff_Filename   ))      ) CYCLE Sensor_Loop

    WRITE( *,'(/10x,"Computing effective transmittances for ",a,"...")' ) &
             TRIM(SensorInfo%Sensor_ID)

    ! Read the SpcCoeff data
    ! ----------------------
    Error_Status = Read_SpcCoeff_netCDF( SpcCoeff_Filename, SpcCoeff )
    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error reading netCDF SpcCoeff file '//&
                            TRIM(SpcCoeff_Filename)//'.', &
                            Error_Status )
      STOP
    END IF

    ! Inquire the TauProfile file to get
    ! dimensions and global attributes
    ! ----------------------------------
    Error_Status = Inquire_TauProfile_netCDF( TauProfile_Filename, &
                                              n_Channels     =n_l, &
                                              n_Angles       =n_i, &
                                              n_Profiles     =n_m, &
                                              n_Molecule_Sets=n_j, &
                                              Release        =Release, &
                                              Version        =Version, &
                                              ID_Tag         =ID_Tag , &
                                              History        =History, &
                                              Comment        =Comment  )
    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error inquiring netCDF TauProfile file '//&
                            TRIM(TauProfile_Filename)//' dimensions.', &
                            Error_Status )
      STOP
    END IF

    ! Inquire the file to get the dimension lists
    ! -------------------------------------------
    ! Allocate the array
    ALLOCATE( Channels(n_l), Angles(n_i), Profiles(n_m), STAT=Allocate_Status )
    IF ( Allocate_Status /= 0 ) THEN
      WRITE( Message,'("Error allocating dimension list arrays. STAT = ",i0)' ) &
                      Allocate_Status
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM(Message), &
                            FAILURE )
      STOP
    END IF

    ! Read the dimension lists
    Error_Status = Inquire_TauProfile_netCDF( TauProfile_Filename  , &
                                              Channel_List=Channels, &
                                              Angle_List  =Angles  , &
                                              Profile_List=Profiles  )
    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error inquiring netCDF TauProfile file '//&
                            TRIM(TauProfile_Filename)//' dimension lists.', &
                            Error_Status )
      STOP
    END IF

    ! Create the output files
    ! -----------------------
!    DO j1 = 1, N_DERIVED
!      DO j2 = 1, N_DERIVED_SETS
!        Out_TauProfile_Filename(j2,j1) = TRIM(DIRECTION_NAME(iDir))//'.'//&
!                                         TRIM(SensorInfo%Sensor_ID)//'.'//&
!                                         DERIVED_NAME(j1)//DERIVED_SET_NAME(j2)//&
!                                         '.TauProfile.nc'
!        Error_Status = Create_TauProfile_netCDF( Out_TauProfile_Filename(j2,j1), &
!                                                 LEVEL_PRESSURE, &
!                                                 Channels, &
!                                                 Angles, &
!                                                 Profiles, &
!                                                 (/EFF_WET_IDX,EFF_DRY_IDX,EFF_OZO_IDX/), &
!                                                 Release         =Release, &
!                                                 Version         =Version, &
!                                                 Sensor_ID       =TRIM(SensorInfo%Sensor_ID), &
!                                                 WMO_Satellite_ID=SensorInfo%WMO_Satellite_ID, &
!                                                 WMO_Sensor_ID   =SensorInfo%WMO_Sensor_ID, &
!                                                 ID_Tag          =TRIM(ID_Tag), &
!                                                 Title           =TRIM(DIRECTION_NAME(iDir))//' '//&
!                                                                  DERIVED_NAME(j1)//&
!                                                                  DERIVED_SET_NAME(j2)//&
!                                                                  ' effective transmittances for '//&
!                                                                  TRIM(SensorInfo%Sensor_ID), &
!                                                 History         =PROGRAM_RCS_ID//'; '//TRIM(History), &
!                                                 Comment         =TRIM(Comment) )
!        IF ( Error_Status /= SUCCESS ) THEN
!          CALL Display_Message( PROGRAM_NAME, &
!                                'Error creating netCDF TauProfile file '//&
!                                TRIM(Out_TauProfile_Filename(j2,j1)), &
!                                Error_Status )
!          STOP
!        END IF
!      END DO
!    END DO

    ! Allocate the statistics arrays
    ! ------------------------------
    ALLOCATE( delta_Tb( n_i, n_m, N_DERIVED_SETS, N_DERIVED), &
              STAT=Allocate_Status )
    IF ( Allocate_Status /= 0 ) THEN
      WRITE( Message,'("Error allocating dTb array. STAT = ",i0)' ) &
                      Allocate_Status
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM(Message), &
                            FAILURE )
      STOP
    END IF

    ! Open the file to output stats info
    ! ----------------------------------
    dTb_Filename = TRIM(SensorInfo%Sensor_ID)//'.dTb_Stats.bin'
    Error_Status = Open_Binary_File( dTb_Filename, &
                                     dTb_FileID  , &
                                     For_Output=SET )
    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error opening Stats file '//TRIM(dTb_Filename), &
                            Error_Status )
      STOP
    END IF
    ! Write the data dimensions and frequency grid
    WRITE( dTb_FileID ) n_i, n_m, N_DERIVED_SETS, N_DERIVED, n_l
    WRITE( dTb_FileID ) SpcCoeff%Wavenumber

    ! Begin CHANNEL loop
    ! ------------------
    Channel_Loop: DO l = 1, n_l

      ! Initialise the statistics arrays
      delta_Tb  = ZERO

      ! Begin DERIVED TAU loop
      ! ----------------------
      Derived_Loop: DO j1 = 1, N_DERIVED  ! WVO, DOZ, or WVD

        ! Set the molecule indices for the current derived master
        ! -------------------------------------------------------
        SELECT CASE (j1)
          CASE (WVO_DERIVED); Tau_Idx = WVO_DERIVED_IDX
          CASE (DOZ_DERIVED); Tau_Idx = DOZ_DERIVED_IDX
          CASE (WVD_DERIVED); Tau_Idx = WVD_DERIVED_IDX
        END SELECT

        ! Begin the DERIVED SUBSET loop
        ! -----------------------------
        DerivedSubset_Loop: DO j2 = 1, N_DERIVED_SETS  ! 2

          ! Begin the PROFILE and ANGLE loops
          ! ---------------------------------
          Profile_Loop: DO m = 1, n_m
            Angle_Loop:   DO i = 1, n_i

              ! Read the transmittance data
              ! ---------------------------
              Molecule_Loop: DO j = 1, N_READ_IDX

                ! Set the particular transmittance to read
                SELECT CASE (Tau_Idx(j))
                  CASE (ALL_IDX); Tau => Tau_ALL
                  CASE (WVO_IDX); Tau => Tau_WVO
                  CASE (DOZ_IDX); Tau => Tau_DOZ
                  CASE (WVD_IDX); Tau => Tau_WVD
                  CASE (WET_IDX); Tau => Tau_WET
                  CASE (DRY_IDX); Tau => Tau_DRY
                  CASE (OZO_IDX); Tau => Tau_OZO
                END SELECT

                ! Read the data from file
                Error_Status = Read_TauProfile_netCDF( TauProfile_Filename, &
                                                       Channels(l), &
                                                       Angles(i)  , &
                                                       Profiles(m), &
                                                       Tau_Idx(j) , &
                                                       Tau        , &
                                                       Quiet=SET    )
                IF ( Error_Status /= SUCCESS ) THEN
                  WRITE( Message,'("Error reading channel ",i0,", angle ",i0,", profile ",i0,&
                                  &", and molid ",i0," from ", a)' ) &
                                  Channels(l), i, Profiles(m), Tau_Idx(j), TRIM(TauProfile_Filename)
                  CALL Display_Message( PROGRAM_NAME, &
                                        TRIM(Message), &
                                        Error_Status )
                  STOP
                END IF

                ! Nullify the pointer
                NULLIFY(Tau)

              END DO Molecule_Loop

              ! Perform RT using the LBL Tau_ALL
              ! --------------------------------
              Tb_ALL = Simple_RT( SpcCoeff, Channels(l), Atm%Layer_Temperature(:,m), Tau_ALL )

              ! Perform RT using the effective total transmittances
              ! ---------------------------------------------------
              ! Initialise the effective transmittance arrays
              Tau_EffWET = ZERO
              Tau_EffDRY = ZERO
              Tau_EffOZO = ZERO
              ! Compute the transmittance components
              SELECT CASE (j1)
                ! WVO-derived
                CASE (WVO_DERIVED)
                  Tau_EffDRY = Compute_EffTau( Tau_ALL, Tau_WVO )
                  IF ( j2 == 1 ) THEN
                    Tau_EffWET = Tau_WET; CALL Correct_EffTau(Tau_EffWET)
                    Tau_EffOZO = Compute_EffTau( Tau_WVO, Tau_WET )
                  ELSE
                    Tau_EffWET = Compute_EffTau( Tau_WVO, Tau_OZO )
                    Tau_EffOZO = Tau_OZO; CALL Correct_EffTau(Tau_EffOZO)
                  END IF
                ! DOZ-derived
                CASE (DOZ_DERIVED)
                  Tau_EffWET = Compute_EffTau( Tau_ALL, Tau_DOZ )
                  IF ( j2 == 1 ) THEN
                    Tau_EffDRY = Tau_DRY; CALL Correct_EffTau(Tau_EffDRY)
                    Tau_EffOZO = Compute_EffTau( Tau_DOZ, Tau_DRY )
                  ELSE
                    Tau_EffDRY = Compute_EffTau( Tau_DOZ, Tau_OZO )
                    Tau_EffOZO = Tau_OZO; CALL Correct_EffTau(Tau_EffOZO)
                  END IF
                ! WVD-derived
                CASE (WVD_DERIVED)
                  Tau_EffOZO = Compute_EffTau( Tau_ALL, Tau_WVD )
                  IF ( j2 == 1 ) THEN
                    Tau_EffWET = Tau_WET; CALL Correct_EffTau(Tau_EffWET)
                    Tau_EffDRY = Compute_EffTau( Tau_WVD, Tau_WET )
                  ELSE
                    Tau_EffWET = Compute_EffTau( Tau_WVD, Tau_DRY )
                    Tau_EffDRY = Tau_DRY; CALL Correct_EffTau(Tau_EffDRY)
                  END IF
              END SELECT

              ! Compute the effective total transmittance
              Tau_EffALL = Tau_EffWET * Tau_EffDRY * Tau_EffOZO

              ! Compute the Tb
              Tb_EffALL = Simple_RT( SpcCoeff, Channels(l), Atm%Layer_Temperature(:,m), Tau_EffALL )

              ! Accumulate the temperature differences
              ! --------------------------------------
              delta_Tb(i,m,j2,j1) = Tb_ALL - Tb_EffALL

            END DO Angle_Loop
          END DO Profile_Loop
        END DO DerivedSubset_Loop
      END DO Derived_Loop

      ! Write the dTb's to file
      WRITE( dTb_FileID ) delta_Tb
      WRITE( *,'(5x,"Channel ", i0,"(",f7.2,")")' ) Channels(l), SpcCoeff%Wavenumber(l)

    END DO Channel_Loop

    CLOSE( dTb_FileID )

    ! Deallocate arrays for current sensor
    ! ------------------------------------
    DEALLOCATE( Channels, Angles, Profiles, &
                delta_Tb, &
                STAT=Allocate_Status )
    IF ( Allocate_Status /= 0 ) THEN
      WRITE( Message,'("Error deallocating arrays for ",a,". STAT = ",i0)' ) &
                      TRIM(SensorInfo%Sensor_Id), Allocate_Status
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM(Message), &
                            FAILURE )
      STOP
    END IF

    ! Destroy the current SpcCoeff structure
    ! --------------------------------------
    Error_Status = Destroy_SpcCoeff( SpcCoeff )
    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error destroying SpcCoeff data structure.', &
                            FAILURE )
      STOP
    END IF

    ! Destroy the current SensorInfo structure
    ! ----------------------------------------
    Error_Status = Destroy_SensorInfo( SensorInfo )
    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error destroying SensorInfo data structure.', &
                            FAILURE )
      STOP
    END IF

  END DO Sensor_Loop

  ! Destroy the AtmProfile structure
  ! --------------------------------
  Error_Status = Destroy_AtmProfile( Atm )
  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error destroying AtmProfile data structure.', &
                          FAILURE )
    STOP
  END IF

  ! Create a signal file
  ! --------------------
  Error_Status = Create_Signal_File( TRIM(DIRECTION_NAME(iDir))//'.'//PROGRAM_NAME )
  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error creating '//TRIM(DIRECTION_NAME(iDir))//' signal file', &
                          Error_Status )
    STOP
  END IF

  ! Destroy the SensorInfo linked list
  ! ----------------------------------
  Error_Status = Destroy_SensorInfo_List( SensorInfo_List )
  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error destroying SensorInfo linked list.', &
                          WARNING )
  END IF

CONTAINS

  ! Function to compute the effective transmittances
  ! ------------------------------------------------
  FUNCTION Compute_EffTau( Numerator, Denominator ) RESULT( EffTau )
    ! Arguments
    REAL(fp), INTENT(IN)  :: Numerator(:), Denominator(:)
    ! Function result
    REAL(fp) :: EffTau(SIZE(Numerator))
    ! Local parameters
    REAL(fp), PARAMETER :: TOLERANCE = EPSILON(ONE)
    ! Only compute effective transmittance if the denominator
    ! is greater than numerical precision.
    WHERE( ABS(Denominator) > TOLERANCE )
      EffTau = Numerator/Denominator
    ELSEWHERE
      EffTau = ZERO
    END WHERE
    ! Correct the effective transmittances
    CALL Correct_EffTau( EffTau )
  END FUNCTION Compute_EffTau

  ! Subroutine to "correct" the effective transmittances
  ! For any channel, the corrections applied to the
  ! values at layer k are:
  !   i)   If tau(k) < 0,        then tau(k) = 0
  !   ii)  If tau(k) > 1,        then tau(k) = 1
  !   iii) If tau(k) > tau(k-1), then tau(k) = tau(k-1)
  ! ----------------------------------------------------
  SUBROUTINE Correct_EffTau( EffTau )
    ! Arguments
    REAL(fp), INTENT(IN OUT) :: EffTau(:)
    ! Local variables
    INTEGER :: k
    ! Correct for transmittances < 0 and > 1
    WHERE( EffTau < ZERO ) EffTau = ZERO
    WHERE( EffTau > ONE  ) EffTau = ONE
    ! Correct for negative optical depths
    DO k = 2, SIZE(EffTau,DIM=1)
      IF ( EffTau(k) > EffTau(k-1) ) EffTau(k) = EffTau(k-1)
    END DO
  END SUBROUTINE Correct_EffTau

  ! Subroutine to perform simple radiative transfer
  ! -----------------------------------------------
  FUNCTION Simple_RT( SpcCoeff, Sensor_Channel, Temperature, Tau ) RESULT( Tb )
    ! Arguments
    TYPE(SpcCoeff_type), INTENT(IN) :: SpcCoeff
    INTEGER            , INTENT(IN) :: Sensor_Channel
    REAL(fp)           , INTENT(IN) :: Temperature(:)
    REAL(fp)           , INTENT(IN) :: Tau(:)
    ! Function result
    REAL(fp) :: Tb
    ! Local variables
    INTEGER :: Error_Status
    INTEGER :: k, n_Layers
    REAL(fp) :: B, Rad

    n_Layers = SIZE(Temperature)
    ! First layer
    Error_Status = Sensor_Radiance( SpcCoeff, Sensor_Channel, Temperature(1), B )
    Rad = B*Tau(1)
    ! Rest of profile
    DO k = 2, n_Layers
      Error_Status = Sensor_Radiance( SpcCoeff, Sensor_Channel, Temperature(k), B )
      Rad = Rad + ( B * (Tau(k-1)-Tau(k)) )
    END DO
    ! Pretend surface. Use last layer temperature as Tsfc. Esfc = 1.0
    Rad = Rad + (B*Tau(n_Layers))
    ! Convert radiances to brightness temperature
    Error_Status = Sensor_Temperature( SpcCoeff, Sensor_Channel, Rad, Tb )
  END FUNCTION Simple_RT

END PROGRAM Select_TauProfile


!-------------------------------------------------------------------------------
!> module OCEAN Variables
!!
!! @par Description
!!          Container for ocean variables
!!
!! @author Team SCALE
!! @li      2013-08-31 (T.Yamaura)  [new]
!<
!-------------------------------------------------------------------------------
module mod_ocean_vars
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof
  use scale_debug
  use scale_grid_index

  use scale_const, only: &
     I_SW  => CONST_I_SW, &
     I_LW  => CONST_I_LW
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: OCEAN_vars_setup
  public :: OCEAN_vars_restart_read
  public :: OCEAN_vars_restart_write
  public :: OCEAN_vars_history
  public :: OCEAN_vars_total
  public :: OCEAN_vars_external_in

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  logical,               public :: OCEAN_RESTART_OUTPUT       = .false.         !< output restart file?

  character(len=H_LONG), public :: OCEAN_RESTART_IN_BASENAME  = ''              !< basename of the input file
  character(len=H_LONG), public :: OCEAN_RESTART_OUT_BASENAME = ''              !< basename of the output file
  character(len=H_MID),  public :: OCEAN_RESTART_OUT_TITLE    = 'OCEAN restart' !< title    of the output file
  character(len=H_MID),  public :: OCEAN_RESTART_OUT_DTYPE    = 'DEFAULT'       !< REAL4 or REAL8

  ! prognostic variables
  real(RP), public, allocatable :: OCEAN_TEMP      (:,:)   !< temperature at uppermost ocean layer [K]
  real(RP), public, allocatable :: OCEAN_SFC_TEMP  (:,:)   !< ocean surface skin temperature [K]
  real(RP), public, allocatable :: OCEAN_SFC_albedo(:,:,:) !< ocean surface albedo [0-1]
  real(RP), public, allocatable :: OCEAN_SFC_Z0M   (:,:)   !< ocean surface roughness length for momentum [m]
  real(RP), public, allocatable :: OCEAN_SFC_Z0H   (:,:)   !< ocean surface roughness length for heat [m]
  real(RP), public, allocatable :: OCEAN_SFC_Z0E   (:,:)   !< ocean surface roughness length for vapor [m]

  ! tendency variables
  real(RP), public, allocatable :: OCEAN_TEMP_t      (:,:)   !< tendency of OCEAN_TEMP
  real(RP), public, allocatable :: OCEAN_SFC_TEMP_t  (:,:)   !< tendency of OCEAN_SFC_TEMP
  real(RP), public, allocatable :: OCEAN_SFC_albedo_t(:,:,:) !< tendency of OCEAN_SFC_alebdo
  real(RP), public, allocatable :: OCEAN_SFC_Z0M_t   (:,:)   !< tendency of OCEAN_SFC_Z0M
  real(RP), public, allocatable :: OCEAN_SFC_Z0H_t   (:,:)   !< tendency of OCEAN_SFC_Z0H
  real(RP), public, allocatable :: OCEAN_SFC_Z0E_t   (:,:)   !< tendency of OCEAN_SFC_Z0E

  ! surface variables for restart
  real(RP), public, allocatable :: OCEAN_SFLX_MW  (:,:) !< ocean surface w-momentum flux    [kg/m2/s]
  real(RP), public, allocatable :: OCEAN_SFLX_MU  (:,:) !< ocean surface u-momentum flux    [kg/m2/s]
  real(RP), public, allocatable :: OCEAN_SFLX_MV  (:,:) !< ocean surface v-momentum flux    [kg/m2/s]
  real(RP), public, allocatable :: OCEAN_SFLX_SH  (:,:) !< ocean surface sensible heat flux [J/m2/s]
  real(RP), public, allocatable :: OCEAN_SFLX_LH  (:,:) !< ocean surface latent heat flux   [J/m2/s]
  real(RP), public, allocatable :: OCEAN_SFLX_WH  (:,:) !< ocean surface water heat flux    [J/m2/s]
  real(RP), public, allocatable :: OCEAN_SFLX_evap(:,:) !< ocean surface water vapor flux   [kg/m2/s]

  ! diagnostic variables
  real(RP), public, allocatable :: OCEAN_U10(:,:) !< ocean surface velocity u at 10m [m/s]
  real(RP), public, allocatable :: OCEAN_V10(:,:) !< ocean surface velocity v at 10m [m/s]
  real(RP), public, allocatable :: OCEAN_T2 (:,:) !< ocean surface temperature at 2m [K]
  real(RP), public, allocatable :: OCEAN_Q2 (:,:) !< ocean surface water vapor at 2m [kg/kg]

  ! recieved atmospheric variables
  real(RP), public, allocatable :: ATMOS_TEMP     (:,:)
  real(RP), public, allocatable :: ATMOS_PRES     (:,:)
  real(RP), public, allocatable :: ATMOS_W        (:,:)
  real(RP), public, allocatable :: ATMOS_U        (:,:)
  real(RP), public, allocatable :: ATMOS_V        (:,:)
  real(RP), public, allocatable :: ATMOS_DENS     (:,:)
  real(RP), public, allocatable :: ATMOS_QV       (:,:)
  real(RP), public, allocatable :: ATMOS_PBL      (:,:)
  real(RP), public, allocatable :: ATMOS_SFC_PRES (:,:)
  real(RP), public, allocatable :: ATMOS_SFLX_LW  (:,:)
  real(RP), public, allocatable :: ATMOS_SFLX_SW  (:,:)
  real(RP), public, allocatable :: ATMOS_cosSZA   (:,:)
  real(RP), public, allocatable :: ATMOS_SFLX_prec(:,:)

  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  logical,                private :: OCEAN_VARS_CHECKRANGE      = .false.

  integer,                private, parameter :: VMAX        = 14 !< number of the variables
  integer,                private, parameter :: I_TEMP      =  1
  integer,                private, parameter :: I_SFC_TEMP  =  2
  integer,                private, parameter :: I_ALB_LW    =  3
  integer,                private, parameter :: I_ALB_SW    =  4
  integer,                private, parameter :: I_SFC_Z0M   =  5
  integer,                private, parameter :: I_SFC_Z0H   =  6
  integer,                private, parameter :: I_SFC_Z0E   =  7
  integer,                private, parameter :: I_SFLX_MW   =  8
  integer,                private, parameter :: I_SFLX_MU   =  9
  integer,                private, parameter :: I_SFLX_MV   = 10
  integer,                private, parameter :: I_SFLX_SH   = 11
  integer,                private, parameter :: I_SFLX_LH   = 12
  integer,                private, parameter :: I_SFLX_WH   = 13
  integer,                private, parameter :: I_SFLX_evap = 14

  character(len=H_SHORT), private            :: VAR_NAME(VMAX) !< name  of the variables
  character(len=H_MID),   private            :: VAR_DESC(VMAX) !< desc. of the variables
  character(len=H_SHORT), private            :: VAR_UNIT(VMAX) !< unit  of the variables

  data VAR_NAME / 'OCEAN_TEMP',      &
                  'OCEAN_SFC_TEMP',  &
                  'OCEAN_ALB_LW',    &
                  'OCEAN_ALB_SW',    &
                  'OCEAN_SFC_Z0M',   &
                  'OCEAN_SFC_Z0H',   &
                  'OCEAN_SFC_Z0E',   &
                  'OCEAN_SFLX_MW',   &
                  'OCEAN_SFLX_MU',   &
                  'OCEAN_SFLX_MV',   &
                  'OCEAN_SFLX_SH',   &
                  'OCEAN_SFLX_LH',   &
                  'OCEAN_SFLX_WH',   &
                  'OCEAN_SFLX_evap'  /
  data VAR_DESC / 'temperature at uppermost ocean layer', &
                  'ocean surface skin temperature',             &
                  'ocean surface albedo (longwave)',            &
                  'ocean surface albedo (shortwave)',           &
                  'ocean surface roughness length (momentum)',  &
                  'ocean surface roughness length (heat)',      &
                  'ocean surface roughness length (vapor)',     &
                  'ocean surface w-momentum flux',              &
                  'ocean surface u-momentum flux',              &
                  'ocean surface v-momentum flux',              &
                  'ocean surface sensible heat flux',           &
                  'ocean surface latent heat flux',             &
                  'ocean surface water heat flux',              &
                  'ocean surface water vapor flux'              /
  data VAR_UNIT / 'K',       &
                  'K',       &
                  '0-1',     &
                  '0-1',     &
                  'm',       &
                  'm',       &
                  'm',       &
                  'kg/m2/s', &
                  'kg/m2/s', &
                  'kg/m2/s', &
                  'J/m2/s',  &
                  'J/m2/s',  &
                  'J/m2/s',  &
                  'kg/m2/s'  /

  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  !> Setup
  subroutine OCEAN_vars_setup
    use scale_process, only: &
       PRC_MPIstop
    use scale_const, only: &
       UNDEF => CONST_UNDEF
    implicit none

    NAMELIST / PARAM_OCEAN_VARS /  &
       OCEAN_RESTART_IN_BASENAME,  &
       OCEAN_RESTART_OUTPUT,       &
       OCEAN_RESTART_OUT_BASENAME, &
       OCEAN_RESTART_OUT_TITLE,    &
       OCEAN_VARS_CHECKRANGE

    integer :: ierr
    integer :: iv
    !---------------------------------------------------------------------------

    if( IO_L ) write(IO_FID_LOG,*)
    if( IO_L ) write(IO_FID_LOG,*) '++++++ Module[VARS] / Categ[OCEAN] / Origin[SCALE-LES]'

    allocate( OCEAN_TEMP      (IA,JA)   )
    allocate( OCEAN_SFC_TEMP  (IA,JA)   )
    allocate( OCEAN_SFC_albedo(IA,JA,2) )
    allocate( OCEAN_SFC_Z0M   (IA,JA)   )
    allocate( OCEAN_SFC_Z0H   (IA,JA)   )
    allocate( OCEAN_SFC_Z0E   (IA,JA)   )
    OCEAN_TEMP      (:,:)   = UNDEF
    OCEAN_SFC_TEMP  (:,:)   = UNDEF
    OCEAN_SFC_albedo(:,:,:) = UNDEF
    OCEAN_SFC_Z0M   (:,:)   = UNDEF
    OCEAN_SFC_Z0H   (:,:)   = UNDEF
    OCEAN_SFC_Z0E   (:,:)   = UNDEF

    allocate( OCEAN_TEMP_t      (IA,JA)   )
    allocate( OCEAN_SFC_TEMP_t  (IA,JA)   )
    allocate( OCEAN_SFC_albedo_t(IA,JA,2) )
    allocate( OCEAN_SFC_Z0M_t   (IA,JA)   )
    allocate( OCEAN_SFC_Z0H_t   (IA,JA)   )
    allocate( OCEAN_SFC_Z0E_t   (IA,JA)   )
    OCEAN_TEMP_t      (:,:)   = UNDEF
    OCEAN_SFC_TEMP_t  (:,:)   = UNDEF
    OCEAN_SFC_albedo_t(:,:,:) = UNDEF
    OCEAN_SFC_Z0M_t   (:,:)   = UNDEF
    OCEAN_SFC_Z0H_t   (:,:)   = UNDEF
    OCEAN_SFC_Z0E_t   (:,:)   = UNDEF

    allocate( OCEAN_SFLX_MW  (IA,JA) )
    allocate( OCEAN_SFLX_MU  (IA,JA) )
    allocate( OCEAN_SFLX_MV  (IA,JA) )
    allocate( OCEAN_SFLX_SH  (IA,JA) )
    allocate( OCEAN_SFLX_LH  (IA,JA) )
    allocate( OCEAN_SFLX_WH  (IA,JA) )
    allocate( OCEAN_SFLX_evap(IA,JA) )
    OCEAN_SFLX_MW  (:,:) = UNDEF
    OCEAN_SFLX_MU  (:,:) = UNDEF
    OCEAN_SFLX_MV  (:,:) = UNDEF
    OCEAN_SFLX_SH  (:,:) = UNDEF
    OCEAN_SFLX_LH  (:,:) = UNDEF
    OCEAN_SFLX_WH  (:,:) = UNDEF
    OCEAN_SFLX_evap(:,:) = UNDEF

    allocate( OCEAN_U10(IA,JA) )
    allocate( OCEAN_V10(IA,JA) )
    allocate( OCEAN_T2 (IA,JA) )
    allocate( OCEAN_Q2 (IA,JA) )
    OCEAN_U10(:,:) = UNDEF
    OCEAN_V10(:,:) = UNDEF
    OCEAN_T2 (:,:) = UNDEF
    OCEAN_Q2 (:,:) = UNDEF

    allocate( ATMOS_TEMP     (IA,JA) )
    allocate( ATMOS_PRES     (IA,JA) )
    allocate( ATMOS_W        (IA,JA) )
    allocate( ATMOS_U        (IA,JA) )
    allocate( ATMOS_V        (IA,JA) )
    allocate( ATMOS_DENS     (IA,JA) )
    allocate( ATMOS_QV       (IA,JA) )
    allocate( ATMOS_PBL      (IA,JA) )
    allocate( ATMOS_SFC_PRES (IA,JA) )
    allocate( ATMOS_SFLX_LW  (IA,JA) )
    allocate( ATMOS_SFLX_SW  (IA,JA) )
    allocate( ATMOS_cosSZA   (IA,JA) )
    allocate( ATMOS_SFLX_prec(IA,JA) )
    ATMOS_TEMP     (:,:) = UNDEF
    ATMOS_PRES     (:,:) = UNDEF
    ATMOS_W        (:,:) = UNDEF
    ATMOS_U        (:,:) = UNDEF
    ATMOS_V        (:,:) = UNDEF
    ATMOS_DENS     (:,:) = UNDEF
    ATMOS_QV       (:,:) = UNDEF
    ATMOS_PBL      (:,:) = UNDEF
    ATMOS_SFC_PRES (:,:) = UNDEF
    ATMOS_SFLX_LW  (:,:) = UNDEF
    ATMOS_SFLX_SW  (:,:) = UNDEF
    ATMOS_cosSZA   (:,:) = UNDEF
    ATMOS_SFLX_prec(:,:) = UNDEF

    !--- read namelist
    rewind(IO_FID_CONF)
    read(IO_FID_CONF,nml=PARAM_OCEAN_VARS,iostat=ierr)
    if( ierr < 0 ) then !--- missing
       if( IO_L ) write(IO_FID_LOG,*) '*** Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       write(*,*) 'xxx Not appropriate names in namelist PARAM_OCEAN_VARS. Check!'
       call PRC_MPIstop
    endif
    if( IO_LNML ) write(IO_FID_LOG,nml=PARAM_OCEAN_VARS)

    if( IO_L ) write(IO_FID_LOG,*)
    if( IO_L ) write(IO_FID_LOG,*) '*** List of prognostic variables (OCEAN) ***'
    if( IO_L ) write(IO_FID_LOG,'(1x,A,A15,A,A32,3(A))') &
               '***       |','VARNAME        ','|', 'DESCRIPTION                     ','[', 'UNIT            ',']'
    do iv = 1, VMAX
       if( IO_L ) write(IO_FID_LOG,'(1x,A,i3,A,A15,A,A32,3(A))') &
                  '*** NO.',iv,'|',VAR_NAME(iv),'|',VAR_DESC(iv),'[',VAR_UNIT(iv),']'

    enddo

    if( IO_L ) write(IO_FID_LOG,*)
    if ( OCEAN_RESTART_IN_BASENAME /= '' ) then
       if( IO_L ) write(IO_FID_LOG,*) '*** Restart input?  : ', trim(OCEAN_RESTART_IN_BASENAME)
    else
       if( IO_L ) write(IO_FID_LOG,*) '*** Restart input?  : NO'
    endif
    if (       OCEAN_RESTART_OUTPUT             &
         .AND. OCEAN_RESTART_OUT_BASENAME /= '' ) then
       if( IO_L ) write(IO_FID_LOG,*) '*** Restart output? : ', trim(OCEAN_RESTART_OUT_BASENAME)
    else
       if( IO_L ) write(IO_FID_LOG,*) '*** Restart output? : NO'
       OCEAN_RESTART_OUTPUT = .false.
    endif

    return
  end subroutine OCEAN_vars_setup

  !-----------------------------------------------------------------------------
  !> Read ocean restart
  subroutine OCEAN_vars_restart_read
    use scale_fileio, only: &
       FILEIO_read
    use mod_ocean_admin, only: &
       OCEAN_sw
    implicit none
    !---------------------------------------------------------------------------

    if( IO_L ) write(IO_FID_LOG,*)
    if( IO_L ) write(IO_FID_LOG,*) '*** Input restart file (OCEAN) ***'

    if ( OCEAN_sw .and. OCEAN_RESTART_IN_BASENAME /= '' ) then
       if( IO_L ) write(IO_FID_LOG,*) '*** basename: ', trim(OCEAN_RESTART_IN_BASENAME)

       call FILEIO_read( OCEAN_TEMP(:,:),                                               & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_TEMP),      'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFC_TEMP(:,:),                                           & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_SFC_TEMP),  'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFC_albedo(:,:,I_LW),                                    & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_ALB_LW),    'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFC_albedo(:,:,I_SW),                                    & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_ALB_SW),    'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFC_Z0M(:,:),                                            & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_SFC_Z0M),   'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFC_Z0H(:,:),                                            & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_SFC_Z0H),   'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFC_Z0E(:,:),                                            & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_SFC_Z0E),   'XY', step=1 ) ! [IN]

       call FILEIO_read( OCEAN_SFLX_MW(:,:),                                            & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_SFLX_MW),   'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFLX_MU(:,:),                                            & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_SFLX_MU),   'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFLX_MV(:,:),                                            & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_SFLX_MV),   'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFLX_SH(:,:),                                            & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_SFLX_SH),   'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFLX_LH(:,:),                                            & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_SFLX_LH),   'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFLX_WH(:,:),                                            & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_SFLX_WH),   'XY', step=1 ) ! [IN]
       call FILEIO_read( OCEAN_SFLX_evap(:,:),                                          & ! [OUT]
                         OCEAN_RESTART_IN_BASENAME, VAR_NAME(I_SFLX_evap), 'XY', step=1 ) ! [IN]

       call OCEAN_vars_total
    else
       if( IO_L ) write(IO_FID_LOG,*) '*** restart file for ocean is not specified.'
    endif

    return
  end subroutine OCEAN_vars_restart_read

  !-----------------------------------------------------------------------------
  !> Write ocean restart
  subroutine OCEAN_vars_restart_write
    use scale_time, only: &
       TIME_gettimelabel
    use scale_fileio, only: &
       FILEIO_write
    use mod_ocean_admin, only: &
       OCEAN_sw
    implicit none

    character(len=15)     :: timelabel
    character(len=H_LONG) :: basename
    !---------------------------------------------------------------------------

    if ( OCEAN_sw .and. OCEAN_RESTART_OUT_BASENAME /= '' ) then

       call TIME_gettimelabel( timelabel )
       write(basename,'(A,A,A)') trim(OCEAN_RESTART_OUT_BASENAME), '_', trim(timelabel)

       if( IO_L ) write(IO_FID_LOG,*)
       if( IO_L ) write(IO_FID_LOG,*) '*** Output restart file (OCEAN) ***'
       if( IO_L ) write(IO_FID_LOG,*) '*** basename: ', trim(basename)

       call OCEAN_vars_total

       call FILEIO_write( OCEAN_TEMP(:,:),            basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_TEMP),           VAR_DESC(I_TEMP),        VAR_UNIT(I_TEMP),        & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFC_TEMP(:,:),        basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_SFC_TEMP),       VAR_DESC(I_SFC_TEMP),    VAR_UNIT(I_SFC_TEMP),    & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFC_albedo(:,:,I_LW), basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_ALB_LW),         VAR_DESC(I_ALB_LW),      VAR_UNIT(I_ALB_LW),      & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFC_albedo(:,:,I_SW), basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_ALB_SW),         VAR_DESC(I_ALB_SW),      VAR_UNIT(I_ALB_SW),      & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFC_Z0M(:,:),         basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_SFC_Z0M),        VAR_DESC(I_SFC_Z0M),     VAR_UNIT(I_SFC_Z0M),     & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFC_Z0H(:,:),         basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_SFC_Z0H),        VAR_DESC(I_SFC_Z0H),     VAR_UNIT(I_SFC_Z0H),     & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFC_Z0E(:,:),         basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_SFC_Z0E),        VAR_DESC(I_SFC_Z0E),     VAR_UNIT(I_SFC_Z0E),     & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFLX_MW(:,:),         basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_SFLX_MW),        VAR_DESC(I_SFLX_MW),     VAR_UNIT(I_SFLX_MW),     & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFLX_MU(:,:),         basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_SFLX_MU),        VAR_DESC(I_SFLX_MU),     VAR_UNIT(I_SFLX_MU),     & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFLX_MV(:,:),         basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_SFLX_MV),        VAR_DESC(I_SFLX_MV),     VAR_UNIT(I_SFLX_MV),     & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFLX_SH(:,:),         basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_SFLX_SH),        VAR_DESC(I_SFLX_SH),     VAR_UNIT(I_SFLX_SH),     & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFLX_LH(:,:),         basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_SFLX_LH),        VAR_DESC(I_SFLX_LH),     VAR_UNIT(I_SFLX_LH),     & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFLX_WH(:,:),         basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_SFLX_WH),        VAR_DESC(I_SFLX_WH),     VAR_UNIT(I_SFLX_WH),     & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]
       call FILEIO_write( OCEAN_SFLX_evap(:,:),       basename,                OCEAN_RESTART_OUT_TITLE, & ! [IN]
                          VAR_NAME(I_SFLX_evap),      VAR_DESC(I_SFLX_evap),   VAR_UNIT(I_SFLX_evap),   & ! [IN]
                          'XY',                       OCEAN_RESTART_OUT_DTYPE, nohalo=.true.            ) ! [IN]

    endif

    return
  end subroutine OCEAN_vars_restart_write

  !-----------------------------------------------------------------------------
  !> History output set for ocean variables
  subroutine OCEAN_vars_history
    use scale_time, only: &
       TIME_DTSEC_OCEAN
    use scale_history, only: &
       HIST_in
    implicit none
    !---------------------------------------------------------------------------

    if ( OCEAN_VARS_CHECKRANGE ) then
       call VALCHECK( OCEAN_TEMP      (IS:IE,JS:JE),      0.0_RP, 1000.0_RP, VAR_NAME(I_TEMP),     &
                     __FILE__, __LINE__ )
       call VALCHECK( OCEAN_SFC_TEMP  (IS:IE,JS:JE),      0.0_RP, 1000.0_RP, VAR_NAME(I_SFC_TEMP), &
                     __FILE__, __LINE__ )
       call VALCHECK( OCEAN_SFC_albedo(IS:IE,JS:JE,I_LW), 0.0_RP,    2.0_RP, VAR_NAME(I_ALB_LW),   &
                     __FILE__, __LINE__ )
       call VALCHECK( OCEAN_SFC_albedo(IS:IE,JS:JE,I_SW), 0.0_RP,    2.0_RP, VAR_NAME(I_ALB_SW),   &
                     __FILE__, __LINE__ )
       call VALCHECK( OCEAN_SFC_Z0M   (IS:IE,JS:JE),      0.0_RP, 1000.0_RP, VAR_NAME(I_SFC_Z0M),  &
                     __FILE__, __LINE__ )
       call VALCHECK( OCEAN_SFC_Z0H   (IS:IE,JS:JE),      0.0_RP, 1000.0_RP, VAR_NAME(I_SFC_Z0H),  &
                     __FILE__, __LINE__ )
       call VALCHECK( OCEAN_SFC_Z0E   (IS:IE,JS:JE),      0.0_RP, 1000.0_RP, VAR_NAME(I_SFC_Z0E),  &
                     __FILE__, __LINE__ )
    endif

    call HIST_in( OCEAN_TEMP      (:,:),      VAR_NAME(I_TEMP),     VAR_DESC(I_TEMP),     VAR_UNIT(I_TEMP)     )
    call HIST_in( OCEAN_SFC_TEMP  (:,:),      VAR_NAME(I_SFC_TEMP), VAR_DESC(I_SFC_TEMP), VAR_UNIT(I_SFC_TEMP) )
    call HIST_in( OCEAN_SFC_albedo(:,:,I_LW), VAR_NAME(I_ALB_LW),   VAR_DESC(I_ALB_LW),   VAR_UNIT(I_ALB_LW)   )
    call HIST_in( OCEAN_SFC_albedo(:,:,I_SW), VAR_NAME(I_ALB_SW),   VAR_DESC(I_ALB_SW),   VAR_UNIT(I_ALB_SW)   )
    call HIST_in( OCEAN_SFC_Z0M   (:,:),      VAR_NAME(I_SFC_Z0M),  VAR_DESC(I_SFC_Z0M),  VAR_UNIT(I_SFC_Z0M)  )
    call HIST_in( OCEAN_SFC_Z0H   (:,:),      VAR_NAME(I_SFC_Z0H),  VAR_DESC(I_SFC_Z0H),  VAR_UNIT(I_SFC_Z0H)  )
    call HIST_in( OCEAN_SFC_Z0E   (:,:),      VAR_NAME(I_SFC_Z0E),  VAR_DESC(I_SFC_Z0E),  VAR_UNIT(I_SFC_Z0E)  )

    call HIST_in( OCEAN_SFLX_MW  (:,:), VAR_NAME(I_SFLX_MW),   VAR_DESC(I_SFLX_MW),   VAR_UNIT(I_SFLX_MW)   )
    call HIST_in( OCEAN_SFLX_MU  (:,:), VAR_NAME(I_SFLX_MU),   VAR_DESC(I_SFLX_MU),   VAR_UNIT(I_SFLX_MU)   )
    call HIST_in( OCEAN_SFLX_MV  (:,:), VAR_NAME(I_SFLX_MV),   VAR_DESC(I_SFLX_MV),   VAR_UNIT(I_SFLX_MV)   )
    call HIST_in( OCEAN_SFLX_SH  (:,:), VAR_NAME(I_SFLX_SH),   VAR_DESC(I_SFLX_SH),   VAR_UNIT(I_SFLX_SH)   )
    call HIST_in( OCEAN_SFLX_LH  (:,:), VAR_NAME(I_SFLX_LH),   VAR_DESC(I_SFLX_LH),   VAR_UNIT(I_SFLX_LH)   )
    call HIST_in( OCEAN_SFLX_WH  (:,:), VAR_NAME(I_SFLX_WH),   VAR_DESC(I_SFLX_WH),   VAR_UNIT(I_SFLX_WH)   )
    call HIST_in( OCEAN_SFLX_evap(:,:), VAR_NAME(I_SFLX_evap), VAR_DESC(I_SFLX_evap), VAR_UNIT(I_SFLX_evap) )

    return
  end subroutine OCEAN_vars_history

  !-----------------------------------------------------------------------------
  !> Budget monitor for ocean
  subroutine OCEAN_vars_total
    use scale_les_statistics, only: &
       STATISTICS_checktotal, &
       STAT_total
    implicit none

    real(RP) :: total
    !---------------------------------------------------------------------------

    if ( STATISTICS_checktotal ) then

       call STAT_total( total, OCEAN_TEMP      (:,:),      VAR_NAME(I_TEMP)     )
       call STAT_total( total, OCEAN_SFC_TEMP  (:,:),      VAR_NAME(I_SFC_TEMP) )
       call STAT_total( total, OCEAN_SFC_albedo(:,:,I_LW), VAR_NAME(I_ALB_LW)   )
       call STAT_total( total, OCEAN_SFC_albedo(:,:,I_SW), VAR_NAME(I_ALB_SW)   )
       call STAT_total( total, OCEAN_SFC_Z0M   (:,:),      VAR_NAME(I_SFC_Z0M)  )
       call STAT_total( total, OCEAN_SFC_Z0H   (:,:),      VAR_NAME(I_SFC_Z0H)  )
       call STAT_total( total, OCEAN_SFC_Z0E   (:,:),      VAR_NAME(I_SFC_Z0E)  )

       call STAT_total( total, OCEAN_SFLX_MW  (:,:), VAR_NAME(I_SFLX_MW)   )
       call STAT_total( total, OCEAN_SFLX_MU  (:,:), VAR_NAME(I_SFLX_MU)   )
       call STAT_total( total, OCEAN_SFLX_MV  (:,:), VAR_NAME(I_SFLX_MV)   )
       call STAT_total( total, OCEAN_SFLX_SH  (:,:), VAR_NAME(I_SFLX_SH)   )
       call STAT_total( total, OCEAN_SFLX_LH  (:,:), VAR_NAME(I_SFLX_LH)   )
       call STAT_total( total, OCEAN_SFLX_WH  (:,:), VAR_NAME(I_SFLX_WH)   )
       call STAT_total( total, OCEAN_SFLX_evap(:,:), VAR_NAME(I_SFLX_evap) )

    endif

    return
  end subroutine OCEAN_vars_total

  !-----------------------------------------------------------------------------
  !> Input from External I/O
  subroutine OCEAN_vars_external_in( &
       OCEAN_TEMP_in,       &
       OCEAN_SFC_TEMP_in,   &
       OCEAN_SFC_albedo_in, &
       OCEAN_SFC_Z0M_in,    &
       OCEAN_SFC_Z0H_in,    &
       OCEAN_SFC_Z0E_in     )
    implicit none

    real(RP), intent(in) :: OCEAN_TEMP_in      (IA,JA)
    real(RP), intent(in) :: OCEAN_SFC_TEMP_in  (IA,JA)
    real(RP), intent(in) :: OCEAN_SFC_albedo_in(IA,JA,2)
    real(RP), intent(in) :: OCEAN_SFC_Z0M_in   (IA,JA)
    real(RP), intent(in) :: OCEAN_SFC_Z0H_in   (IA,JA)
    real(RP), intent(in) :: OCEAN_SFC_Z0E_in   (IA,JA)
    !---------------------------------------------------------------------------

    if( IO_L ) write(IO_FID_LOG,*)
    if( IO_L ) write(IO_FID_LOG,*) '*** External Input file (ocean) ***'

    OCEAN_TEMP      (:,:)   = OCEAN_TEMP_in      (:,:)
    OCEAN_SFC_TEMP  (:,:)   = OCEAN_SFC_TEMP_in  (:,:)
    OCEAN_SFC_albedo(:,:,:) = OCEAN_SFC_albedo_in(:,:,:)
    OCEAN_SFC_Z0M   (:,:)   = OCEAN_SFC_Z0M_in   (:,:)
    OCEAN_SFC_Z0H   (:,:)   = OCEAN_SFC_Z0H_in   (:,:)
    OCEAN_SFC_Z0E   (:,:)   = OCEAN_SFC_Z0E_in   (:,:)

    OCEAN_SFLX_MW  (:,:) = 0.0_RP
    OCEAN_SFLX_MU  (:,:) = 0.0_RP
    OCEAN_SFLX_MV  (:,:) = 0.0_RP
    OCEAN_SFLX_SH  (:,:) = 0.0_RP
    OCEAN_SFLX_LH  (:,:) = 0.0_RP
    OCEAN_SFLX_WH  (:,:) = 0.0_RP
    OCEAN_SFLX_evap(:,:) = 0.0_RP

    call OCEAN_vars_total

    return
  end subroutine OCEAN_vars_external_in

end module mod_ocean_vars


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

!------------------------------------------------------------------------------
!> forward_operator_mod.f90
!>
!> This module contains routines related to the forward operator.
!>
!------------------------------------------------------------------------------
module forward_operator_mod

use types_mod,             only : r8, i8, missing_r8

use time_manager_mod,      only : time_type

use utilities_mod,         only : error_handler, E_ERR

use mpi_utilities_mod,     only : my_task_id

use obs_sequence_mod,      only : init_obs, destroy_obs, obs_sequence_type, &
                                  obs_type, get_obs_values, get_qc,         &
                                  get_obs_def, get_obs_from_key

use obs_def_mod,           only : obs_def_type, get_obs_def_error_variance, &
                                  get_expected_obs_from_def_distrib_state,  &
                                  get_obs_def_type_of_obs

use obs_kind_mod,          only : assimilate_this_type_of_obs, evaluate_this_type_of_obs

use ensemble_manager_mod,  only : ensemble_type, compute_copy_mean_var, &
                                  prepare_to_read_from_vars,            &
                                  prepare_to_write_to_vars,             &
                                  get_my_num_copies, copies_in_window,  &
                                  get_allow_transpose, all_vars_to_all_copies, &
                                  all_copies_to_all_vars, allocate_single_copy, &
                                  get_single_copy, put_single_copy, deallocate_single_copy

use distributed_state_mod, only : create_state_window, free_state_window,   &
                                  get_state

use ensemble_manager_mod,    only : copies_in_window

use quality_control_mod,   only : check_outlier_threshold, get_dart_qc, &
                                  input_qc_ok, good_dart_qc, DARTQC_BAD_INCOMING_QC, &
                                  DARTQC_ASSIM_GOOD_FOP, DARTQC_EVAL_GOOD_FOP, &
                                  DARTQC_NOT_IN_NAMELIST

!------------------------------------------------------------------------------

implicit none

private

public :: get_obs_ens_distrib_state, get_expected_obs_distrib_state

!------------------------------------------------------------------------------
! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"
!------------------------------------------------------------------------------

! Module storage for writing error messages
character(len = 256) :: msgstring, msgstring2

contains

!------------------------------------------------------------------------------
!> Subroutine get_obs_ens_distrib_state
!>
!> Computes the forward observation operators and related quality
!> control indicators.
!>
!------------------------------------------------------------------------------
subroutine get_obs_ens_distrib_state(ens_handle, obs_fwd_op_ens_handle, &
   qc_ens_handle, seq, keys, obs_val_index, input_qc_index, &
   OBS_ERR_VAR_COPY,   OBS_VAL_COPY,   OBS_KEY_COPY, &
   OBS_GLOBAL_QC_COPY, OBS_EXTRA_QC_COPY, OBS_MEAN_COPY, &
   OBS_VAR_COPY, isprior, prior_qc_copy)

type(ensemble_type),     intent(inout) :: ens_handle  !! state ensemble handle
type(ensemble_type),     intent(inout) :: obs_fwd_op_ens_handle  !! observation forward operator handle
type(ensemble_type),     intent(inout) :: qc_ens_handle  !! quality control handle
type(obs_sequence_type), intent(in)    :: seq  !! the observation sequence
integer,                 intent(in)    :: keys(:)  !! observation key numbers
integer,                 intent(in)    :: obs_val_index  !! copy index for observation value
integer,                 intent(in)    :: input_qc_index  !! qc index for incoming QC value
integer,                 intent(in)    :: OBS_ERR_VAR_COPY  !! ensemble copy number for observation error variances
integer,                 intent(in)    :: OBS_VAL_COPY  !! ensemble copy number for observation values
integer,                 intent(in)    :: OBS_KEY_COPY  !! ensemble copy number for observation keys
integer,                 intent(in)    :: OBS_GLOBAL_QC_COPY  !! ensemble copy number for ??
integer,                 intent(in)    :: OBS_EXTRA_QC_COPY  !! ensemble copy number for ??
integer,                 intent(in)    :: OBS_MEAN_COPY  !! ensemble copy number for obs mean values
integer,                 intent(in)    :: OBS_VAR_COPY  !! ensemble copy number for obs variance
logical,                 intent(in)    :: isprior  !! true for prior eval; false for posterior
real(r8),                intent(inout) :: prior_qc_copy(:)  !! array instead of ensemble copy ??

real(r8) :: input_qc(1), obs_value(1), obs_err_var

real(r8), allocatable :: expected_obs(:) !Also regular obs now?

integer :: i, j, k !! index variables
integer :: thiskey(1)
integer :: global_obs_num, global_qc_value
integer :: num_copies_to_calc
integer :: global_ens_index
integer :: ens_size

integer, allocatable  :: istatus(:)
integer, allocatable  :: var_istatus(:)
integer, allocatable  :: my_copy_indices(:) ! The global ens index for each copy a task has

logical :: evaluate_this_ob, assimilate_this_ob

type(time_type) :: dummy_time

type(obs_def_type) :: obs_def
type(obs_type)     :: observation

! IMPORTANT, IT IS ASSUMED THAT ACTUAL ENSEMBLES COME FIRST
! It is also assumed that the ensemble members are in the same
! order in each of the handles

num_copies_to_calc = copies_in_window(ens_handle)

allocate(istatus(num_copies_to_calc))
allocate(expected_obs(num_copies_to_calc))
allocate(my_copy_indices(num_copies_to_calc))

! FIXME: these no longer do anything?
! call prepare_to_write_to_vars(obs_fwd_op_ens_handle)
! call prepare_to_write_to_vars(qc_ens_handle)
! call prepare_to_read_from_vars(ens_handle)

! Set up access to the state
call create_state_window(ens_handle)

ens_size = ens_handle%num_copies - ens_handle%num_extras

if(get_allow_transpose(ens_handle)) then ! giant if for transpose or distributed forward op

   my_copy_indices(:) = ens_handle%my_copies(1:num_copies_to_calc) ! var-complete forward operators

   ! Loop through all observations in the set
   ALL_OBSERVATIONS: do j = 1, obs_fwd_op_ens_handle%num_vars
      ! Get the information on this observation by placing it in temporary
      call get_obs_from_key(seq, keys(j), observation)
      call get_obs_def(observation, obs_def)
      ! Check to see if this observation fails input qc test
      call get_qc(observation, input_qc, input_qc_index)

      ! Get the observation value and error variance
      call get_obs_values(observation, obs_value(1:1), obs_val_index)
      obs_err_var = get_obs_def_error_variance(obs_def)

      ! Loop through all copies stored by this process and set values as needed
      do k = 1, obs_fwd_op_ens_handle%my_num_copies
         ! See if this is the copy for error variance or observed value
         global_ens_index = obs_fwd_op_ens_handle%my_copies(k)
         if(global_ens_index == OBS_ERR_VAR_COPY) then
            ! This copy is the instrument observation error variance; read and
            ! store
            obs_fwd_op_ens_handle%vars(j, k) = obs_err_var

         else if(global_ens_index == OBS_VAL_COPY) then
            ! This copy is the observation from the instrument; read and store
            obs_fwd_op_ens_handle%vars(j, k) = obs_value(1)
         else if(global_ens_index == OBS_KEY_COPY) then
            obs_fwd_op_ens_handle%vars(j, k) = keys(j)
         else if(global_ens_index == OBS_GLOBAL_QC_COPY .and. isprior) then
            obs_fwd_op_ens_handle%vars(j, k) = 0.0_r8
         endif
      enddo

      ! If it is bad, set forward operator status value to -99 and return missing_r8 for obs_value
      ! PAR THIS SUBROUTINE SHOULD EVENTUALLY GO IN THE QUALITY CONTROL MODULE
      if(.not. input_qc_ok(input_qc(1), global_qc_value)) then

         qc_ens_handle%vars(j, :) = 0

         do k=1, obs_fwd_op_ens_handle%my_num_copies
            global_ens_index = obs_fwd_op_ens_handle%my_copies(k)
            ! Update prior/post obs values, mean, etc - but leave the key copy
            ! and the QC copy alone.
            if ((global_ens_index /= OBS_KEY_COPY) .and. &
               (global_ens_index /= OBS_EXTRA_QC_COPY) .and. &
               (global_ens_index /= OBS_GLOBAL_QC_COPY)) then
               ! JH test if the global_ens_index is our extra bad qc copy
               obs_fwd_op_ens_handle%vars(j, k) = missing_r8
            endif
            if (global_ens_index == OBS_GLOBAL_QC_COPY) then
               ! JH set extra fwd_op_ens to bad incoming qc
               obs_fwd_op_ens_handle%vars(j, k) = global_qc_value
            endif
         enddo

         ! No need to do anything else for a failed observation
         cycle ALL_OBSERVATIONS
      endif

      thiskey(1) = keys(j)

      if(qc_ens_handle%my_num_copies > 0) then
         call get_expected_obs_distrib_state(seq, thiskey, &
            dummy_time, isprior, istatus, &
            assimilate_this_ob, evaluate_this_ob, ens_handle, num_copies_to_calc, my_copy_indices, expected_obs)
            obs_fwd_op_ens_handle%vars(j, 1:num_copies_to_calc) = expected_obs
      else ! need to know whether it was assimilate or evaluate this ob.

         call assim_or_eval(seq, thiskey(1), ens_handle%num_vars, assimilate_this_ob, evaluate_this_ob)

      endif

      do k=1, obs_fwd_op_ens_handle%my_num_copies
         global_ens_index = obs_fwd_op_ens_handle%my_copies(k)

         ! Storing assimilate_this_obs, evaluate_this_ob, or ob not in
         ! namelist in OBS_EXTRA_QC_COPY
         if (global_ens_index == OBS_EXTRA_QC_COPY) then
            if (assimilate_this_ob) then
               obs_fwd_op_ens_handle%vars(j, k) = DARTQC_ASSIM_GOOD_FOP
            else if (evaluate_this_ob) then
               obs_fwd_op_ens_handle%vars(j, k) = DARTQC_EVAL_GOOD_FOP
            else
               obs_fwd_op_ens_handle%vars(j, k) = DARTQC_NOT_IN_NAMELIST
            endif
         endif
      enddo

      qc_ens_handle%vars(j, 1:num_copies_to_calc) = istatus(:)

      call check_forward_operator_istatus(num_copies_to_calc, assimilate_this_ob, &
                                 evaluate_this_ob, istatus, expected_obs, keys(j))

   end do ALL_OBSERVATIONS

else ! distributed state

   do i = 1, num_copies_to_calc
      my_copy_indices(i) = i  ! copy-complete fwd operator so indices are 1 to ens_size
   enddo

   ! Loop through all my observations in the set
   MY_OBSERVATIONS: do j = 1,  obs_fwd_op_ens_handle%my_num_vars

   ! convert the local obs number to global obs number
   global_obs_num = obs_fwd_op_ens_handle%my_vars(j)
   thiskey(1) = keys(global_obs_num)

   call get_obs_from_key(seq, keys(global_obs_num), observation)
   call get_obs_def(observation, obs_def)

   ! Get the information on this observation by placing it in temporary
   ! storage. Check to see if this observation fails input qc test
   call get_qc(observation, input_qc, input_qc_index)

   if (isprior) then
      ! this should only need to be done once, in the prior, right?
      obs_fwd_op_ens_handle%copies(OBS_KEY_COPY, j) = thiskey(1)

      ! Check to see if the incoming data qc is bad
      if(.not. input_qc_ok(input_qc(1), global_qc_value)) then
         obs_fwd_op_ens_handle%copies(OBS_GLOBAL_QC_COPY, j) = global_qc_value
         obs_fwd_op_ens_handle%copies(1:ens_size,j) = missing_r8
         ! No need to do anything else for bad incoming qc
         cycle MY_OBSERVATIONS
      endif
   else ! posterior
      ! Check to see if the incoming data qc is bad
      if(.not. input_qc_ok(input_qc(1), global_qc_value)) then
         cycle MY_OBSERVATIONS
      endif
   endif

   ! Get the observation value and error variance
   call get_obs_values(observation, obs_value(1:1), obs_val_index)

   obs_err_var = get_obs_def_error_variance(obs_def)

   call get_expected_obs_distrib_state(seq, thiskey, &
      dummy_time, isprior, istatus, &
      assimilate_this_ob, evaluate_this_ob, ens_handle, num_copies_to_calc, my_copy_indices, expected_obs)

      obs_fwd_op_ens_handle%copies(1:num_copies_to_calc, j) = expected_obs

   ! collect dart qc
   global_qc_value = nint(obs_fwd_op_ens_handle%copies(OBS_GLOBAL_QC_COPY, j))

   call get_dart_qc(istatus, num_copies_to_calc, assimilate_this_ob, evaluate_this_ob, &
                  isprior, global_qc_value)

   ! update the dart qc, error variance and for observed value
   obs_fwd_op_ens_handle%copies(OBS_GLOBAL_QC_COPY, j) = global_qc_value
   obs_fwd_op_ens_handle%copies(OBS_ERR_VAR_COPY  , j) = obs_err_var
   obs_fwd_op_ens_handle%copies(OBS_VAL_COPY      , j) = obs_value(1)

   qc_ens_handle%copies(:, j) = istatus

   call check_forward_operator_istatus(num_copies_to_calc, assimilate_this_ob, evaluate_this_ob, &
                               istatus, expected_obs, thiskey(1))

   end do MY_OBSERVATIONS

endif

! End access to the state
call free_state_window(ens_handle, obs_fwd_op_ens_handle, qc_ens_handle)

! QC Section:
! * Consolidate QC for non-distributed forward operator
! * Check outlier threshold (prior only)
! * Set mean and var to missing_r8 if any forward operator failed.
!   The failure test is any qc_ens_handle%copies = 0.
!   Previously we were testing for any obs_fwd_op_ens_handle%copies = missing_r8 but
!   some models (e.g. CAM) return a non-zero QC, but a forward operator value (not missing_r8)

if (get_allow_transpose(ens_handle)) then
   ! Extra step for non-distributed to consolidate qc values for
   ! each ensemble member into global_qc_value
   allocate(var_istatus(qc_ens_handle%num_copies))

   if (.not. isprior) call put_single_copy(obs_fwd_op_ens_handle, OBS_GLOBAL_QC_COPY, prior_qc_copy)

   MY_OBS: do j = 1,  obs_fwd_op_ens_handle%my_num_vars
      ! collect dart qc
      var_istatus = qc_ens_handle%copies(:,j)

      assimilate_this_ob = (obs_fwd_op_ens_handle%copies(OBS_EXTRA_QC_COPY, j) == DARTQC_ASSIM_GOOD_FOP )
      evaluate_this_ob   = (obs_fwd_op_ens_handle%copies(OBS_EXTRA_QC_COPY, j) == DARTQC_EVAL_GOOD_FOP)
      global_qc_value    = nint(obs_fwd_op_ens_handle%copies(OBS_GLOBAL_QC_COPY, j))

      ! update the status
      call get_dart_qc(var_istatus, qc_ens_handle%num_copies, assimilate_this_ob, evaluate_this_ob, &
                      isprior, global_qc_value)
      obs_fwd_op_ens_handle%copies(OBS_GLOBAL_QC_COPY, j) = global_qc_value

   enddo MY_OBS

   deallocate(var_istatus)

endif

call compute_copy_mean_var(obs_fwd_op_ens_handle, 1, qc_ens_handle%num_copies, &
                           OBS_MEAN_COPY, OBS_VAR_COPY)

!>@todo Science quesion: Should groups be considered separately for outlier threshold test?
QC_LOOP: do j = 1,  obs_fwd_op_ens_handle%my_num_vars

   if (isprior) then

      global_qc_value = nint(obs_fwd_op_ens_handle%copies(OBS_GLOBAL_QC_COPY, j))
      ! check_outlier_threshold could change the global_qc_value
      call check_outlier_threshold(obs_fwd_op_ens_handle%copies(OBS_MEAN_COPY,    j),       &
                                   obs_fwd_op_ens_handle%copies(OBS_VAR_COPY,     j),       &
                                   obs_fwd_op_ens_handle%copies(OBS_VAL_COPY,     j),       &
                                   obs_fwd_op_ens_handle%copies(OBS_ERR_VAR_COPY, j),  seq, &
                              nint(obs_fwd_op_ens_handle%copies(OBS_KEY_COPY,     j)), global_qc_value)

      obs_fwd_op_ens_handle%copies(OBS_GLOBAL_QC_COPY, j) = global_qc_value

   endif

   ! for either prior or posterior, if any forward operator failed,
   ! reset the mean/var to missing_r8, regardless of the DART QC status
   if (any(qc_ens_handle%copies(:, j) /= 0)) then
      obs_fwd_op_ens_handle%copies(OBS_MEAN_COPY, j) = missing_r8
      obs_fwd_op_ens_handle%copies(OBS_VAR_COPY,  j) = missing_r8
   endif

end do QC_LOOP

if (isprior) call get_single_copy(obs_fwd_op_ens_handle, OBS_GLOBAL_QC_COPY, prior_qc_copy)

deallocate(expected_obs, istatus, my_copy_indices)

end subroutine get_obs_ens_distrib_state

!------------------------------------------------------------------------------
!> Subroutine get_expected_obs_distrib_state
!>
!> Compute forward operator for set of obs in sequence for distributed state vector.
!>@todo does this need to be for a set of obs?
!>
!------------------------------------------------------------------------------
subroutine get_expected_obs_distrib_state(seq, keys, state_time, isprior, &
   istatus, assimilate_this_ob, evaluate_this_ob, state_ens_handle, num_ens, copy_indices, expected_obs)

type(obs_sequence_type), intent(in)    :: seq  !! the observation sequence
integer,                 intent(in)    :: keys(:)  !! list of obs numbers
type(time_type),         intent(in)    :: state_time  !! time state vector data is valid for
logical,                 intent(in)    :: isprior  !! true if prior; false if posterior
integer,                 intent(in)    :: num_ens  !! number of ensemble members (decl must preceed use)
integer,                 intent(out)   :: istatus(num_ens)  !! FO return codes; 0=ok, >0 is error, <0 reserved for system use
logical,                 intent(out)   :: assimilate_this_ob  !! true if assimilated; false otherwise
logical,                 intent(out)   :: evaluate_this_ob  !! true if evaluated; false otherwise
type(ensemble_type),     intent(in)    :: state_ens_handle  !! state ensemble handle
integer,                 intent(in)    :: copy_indices(num_ens)  !! ??
real(r8),                intent(inout) :: expected_obs(num_ens)  !! the array of computed forward operator values

type(obs_type)     :: obs
type(obs_def_type) :: obs_def
character(len=32)  :: state_size_string, obs_key_string, identity_obs_string

integer :: obs_kind_ind
integer :: num_obs, i

num_obs = size(keys)

! NEED to initialize istatus to okay value
istatus = 0

! Initialize the observation type
!!! Can actually init with the correct size here if wanted
call init_obs(obs, 0, 0)

!>@todo do you ever use this with more than one obs?
do i = 1, num_obs
   call get_obs_from_key(seq, keys(i), obs)
   call get_obs_def(obs, obs_def)

   obs_kind_ind = get_obs_def_type_of_obs(obs_def)

   !location = get_obs_def_location(obs_def)

   ! Check in kind for negative for identity obs
   if(obs_kind_ind < 0) then
      if ( -obs_kind_ind > state_ens_handle%num_vars ) then
         write(state_size_string, *) state_ens_handle%num_vars
         write(obs_key_string, *) keys(i)
         write(identity_obs_string, *) -obs_kind_ind
         write(msgstring,  *) 'unable to compute forward operator for obs number '//trim(adjustl(obs_key_string))
         write(msgstring2, *) 'identity index '//trim(adjustl(identity_obs_string))//&
                              ' must be between 1 and the state size of '//trim(adjustl(state_size_string))
         call error_handler(E_ERR, 'get_expected_obs', msgstring, source, revision, revdate, text2=msgstring2)
      endif

      expected_obs =  get_state(-1*int(obs_kind_ind,i8), state_ens_handle)

      ! FIXME : we currently have no option to eval only identity obs,
      ! or select to skip their assimilation via namelist.
      assimilate_this_ob = .true.; evaluate_this_ob = .false.

   else ! do forward operator for this kind

      call get_expected_obs_from_def_distrib_state(state_ens_handle, num_ens, copy_indices, keys(i), &
         obs_def, obs_kind_ind, state_time, isprior, &
         assimilate_this_ob, evaluate_this_ob, expected_obs, istatus)

   endif
end do

! need to free any observation specific storage that
! might have been allocated.
call destroy_obs(obs)

end subroutine get_expected_obs_distrib_state

!---------------------------------------------------------------------------
!> For a given obs (seq and key) returns the logicals assimilate_this_obs
!> and evaluate_this_obs.
!> This is so a task that does not do a forward operator can still do QC
!> by storing this info in OBS_EXTRA_QC_COPY.
subroutine assim_or_eval(seq, thiskey, numvars, assimilate_this_ob, evaluate_this_ob)

type(obs_sequence_type), intent(in)  :: seq
integer,                 intent(in)  :: thiskey
integer(i8),             intent(in)  :: numvars
logical,                 intent(out) :: assimilate_this_ob
logical,                 intent(out) :: evaluate_this_ob

type(obs_type)      :: obs
integer             :: obs_kind_ind
type(obs_def_type)  :: obs_def

call init_obs(obs, 0, 0)
call get_obs_from_key(seq, thiskey, obs)
call get_obs_def(obs, obs_def)
obs_kind_ind = get_obs_def_type_of_obs(obs_def)

if (obs_kind_ind < 0) then
   if ( -obs_kind_ind > numvars ) then
      call error_handler(E_ERR,  &
      'get_expected_obs', &
      'identity obs is outside of state vector ', &
      source, revision, revdate)
   endif

   ! FIXME : we currently have no option to eval only identity obs,
   ! or select to skip their assimilation via namelist.
   assimilate_this_ob = .true.; evaluate_this_ob = .false.
else

   assimilate_this_ob = assimilate_this_type_of_obs(obs_kind_ind)
   evaluate_this_ob   = evaluate_this_type_of_obs(obs_kind_ind)

endif

end subroutine assim_or_eval

!------------------------------------------------------------------------------
!> Checks for errors from the model_mod forward operator
!> Possible errors:
!>   * Successful istatus but missing_r8 for forward operator
!>   * Negative istatus
!> This routine calls the error handler (E_ERR) if either of these happen.

subroutine check_forward_operator_istatus(num_fwd_ops, assimilate_ob, evaluate_ob, istatus, expected_obs, thiskey)

integer,  intent(in) :: num_fwd_ops
logical,  intent(in) :: assimilate_ob
logical,  intent(in) :: evaluate_ob
integer,  intent(in) :: istatus(num_fwd_ops)
real(r8), intent(in) :: expected_obs(num_fwd_ops)
integer,  intent(in) :: thiskey

integer :: copy

! Check for errors from model_mod forward operator
do copy = 1, num_fwd_ops

   ! Successful istatus but missing_r8 for forward operator
   if(istatus(copy) == 0) then
      if ((assimilate_ob .or. evaluate_ob) .and. (expected_obs(copy) == missing_r8)) then
         write(msgstring, *) 'istatus was 0 (OK) but forward operator returned missing value.'
         write(msgstring2, *) 'observation number ', thiskey
         call error_handler(E_ERR,'check_forward_operator_istatus', msgstring, &
                    source, revision, revdate, text2=msgstring2)
      endif
   ! Negative istatus
   else if (istatus(copy) < 0) then
      write(msgstring, *) 'istatus must not be <0 from forward operator. 0=OK, >0 for error'
      write(msgstring2, *) 'observation number ', thiskey
      call error_handler(E_ERR,'check_forward_operator_istatus', msgstring, &
                    source, revision, revdate, text2=msgstring2)
   endif

enddo

end subroutine check_forward_operator_istatus

!------------------------------------------------------------------------------
end module forward_operator_mod

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


! *****************************COPYRIGHT*******************************
! (C) Crown copyright Met Office. All rights reserved.
! For further details please refer to the file COPYRIGHT.txt
! which you should have received as part of this distribution.
! *****************************COPYRIGHT*******************************
!
! Module to deal with namelists for input
!
module namelists

  Use parameters
  Use header_data, only : mphys_id
  Use switches

#if SHIPWAY_MICRO == 1
  ! Temporary for adding in 4a switches
  Use mphys_switches, only: iopt_act, option, aerosol_option        &
     , l_aaut, l_aacc, l_aevp, l_ased, iopt_tidy, l_warm            &
     , l_inuc, iopt_rcrit, iopt_inuc                                &
     , l_evaporation, l_rain, l_sed, l_boussinesq, diag_mu_option   &
     , l_sed_3mdiff, l_cons, l_abelshipway, l_condensation          &
     , l_active_inarg2000, l_oneway, l_newoptions
  Use mphys_parameters, only: p1, p2, p3, sp1, sp2, sp3             &
     , max_step_length, max_sed_length
#endif

  implicit none

  namelist/mphys/num_h_moments, num_h_bins, mom_init, &
       h_names, mom_names, mom_units,num_aero_moments,num_aero_bins, &
       aero_mom_init, aero_N_init, aero_sig_init, aero_rd_init, aero_names

  namelist/control/dt, dg_dt, mphys_scheme, mphys_var &
       , wctrl, zctrl, tctrl, pctrl_z, pctrl_v, pctrl_T, ipctrl &
       , xctrl, lhf_ctrl, shf_ctrl, diaglevel, dgstart &
       , init_hydrometeors

  namelist/case/input_file, l_input_file, ifiletype, icase

  namelist/switch/l_mphys, l_advect, l_diverge, l_pupdate &
       , l_fix_qv, l_nomphys_qv, l_noadv_qv, l_posadv_qv &
       , l_fix_theta, l_nomphys_theta, l_noadv_theta  &
       , l_noadv_hydrometeors, l_nodiv_hydrometeors, l_sediment &
       , isurface, l_noadv_aerosols, l_nodiv_aerosols, l_fix_aerosols &
       , l_diverge_advection, l_periodic_bound  &
       , l_force_positive, l_raut, l_constant_density &
       ! TAU bin switches
       , l_act, l_cond_evap, l_coll_coal, l_break, l_fix_supersat &
       , l_dist_activated_drops, mu_act, act_bin_ind

  logical :: iiwarm=.false.
  character(200) :: KiD_outdir=''
  character(200) :: KiD_outfile=''
  real :: set_Nc = 100.  ! for setting cloud number concentration (cm-3)
  real :: amp_fact= 1.0 ! factor applied to the amplitude of the Cu velocity
                        ! field to obtain different clouds. Default is
                        ! the standard case
  real :: cltop=2700.   ! cloud top for the standard Cu case
  real :: no_precip_time = 0.0 ! time that there is no precip process or sedimentation
  real :: smax = 999.0 ! maximum supersaturation that can be used in cond and act
                       ! set to 999 % as default so that this is not used unless
                       ! smax is set in user namelist
  real :: smax_limit_time = 0.0
  namelist/addcontrol/iiwarm, KiD_outdir, KiD_outfile  &
#if SHIPWAY_MICRO == 1
     ! Shipway 4A ...
     , option, l_evap, l_sed_3mdiff &
     , max_step_length, max_sed_length, diag_mu, l_rsource, l_raut &
     , l_evaporation, l_rain, l_sed, l_boussinesq, diag_mu_option   &
     , p1, p2, p3 &
     , sp1, sp2, sp3 &
     , l_abelshipway, l_cons &
     , l_coll_coal, l_cond, l_condensation, iopt_act &
     , aerosol_option, l_aaut, l_aacc, l_aevp, l_ased &
     , iopt_tidy, l_warm, l_inuc, iopt_rcrit   &
     , l_active_inarg2000, iopt_inuc, l_cu_cold, l_oneway, l_newoptions &
#endif
     ! Thompson 09...
     , l_reuse_thompson_lookup &
     ! Flags for KiD-A intercomparison
     , set_Nc, amp_fact, cltop, no_precip_time, smax, smax_limit_time

  ! Namelist input...

  character(200) :: fileName=''
  character(200) :: fileNameIn=''
  character(200) :: fileNameOut=''
  character(200) :: namelistIn='namelists/input.nml'
  character(200) :: fileIn=''
  character(200) :: fileOut=''
  logical :: fexist

  namelist/namelistToUse/fileIn, fileOut

contains

  subroutine read_namelist
    !
    ! Read the namelists from file
    !

#if COMMANDLINE == 1
    ! This bit is F2003 - If your compiler doesnt support
    ! it you need to comment the line out you can then specify
    ! which namelist to use throught namelists/input.nml file
    ! or else use command line processing that works with your
    ! compiler (nearly all will do it but not in a portable way).
    write(*,*) 'Querying command line'
    CALL GET_COMMAND_ARGUMENT(1,fileNameIn)
    CALL GET_COMMAND_ARGUMENT(2,fileNameOut)
#endif

    if (trim(fileNameIn)=='')then  ! Not input at the command line
                                   ! so use input.nml
#ifdef DEF_CASE
      write(namelistIn, '(A,A,A)') 'namelists/', DEF_CASE, '_input.nml'
#endif

      write(*,*) 'Unable to determine input file from command line, so querying ', trim(namelistIn), ' instead...'
      inquire(file=namelistIn, exist=fexist)
      if (fexist) then
        open(2, file=namelistIn)
        read(2, namelistToUse)
        close(2)
        write(*, namelistToUse)
      end if
      fileNameIn  = fileIn
      if (trim(fileOut)/='')fileNameOut = fileOut
    end if

    if (trim(fileNameIn)/='')fileName=fileNameIn

    write(6,*) 'Using namelist: ', trim(fileName)

    open(1, file=fileName)
!    rewind(1)
    read(1,mphys)
!    rewind(1)
    read(1,case)
!    rewind(1)
    read(1,control)
!    rewind(1)
    read(1,switch)
!    rewind(1)
    read(1,addcontrol)
    close(1)

    select case(mphys_scheme)
    case('lem2.4')
       imphys=imphys_lem2_4
       mphys_id='LEM2.4'
    case('tau_bin')
       imphys=imphys_tau_bin
       mphys_id='TAU_bin'
    case('thompson') ! NB same as thompson09
       imphys=imphys_thompson09
       mphys_id='thompson09'
    case('thompson09')
       imphys=imphys_thompson09
       mphys_id='thompson09'
    case('thompson06')
       imphys=imphys_thompson06
       mphys_id='thompson06'
    case('thompson07')
       imphys=imphys_thompson07
       mphys_id='thompson07'
    case('morr_two_moment')
       imphys=imphys_morr_two_moment
       mphys_id='morr_two_moment'
    case('um7_3')
       imphys=imphys_um7_3
       mphys_id='um7_3'
    case('wsm6')
       imphys=imphys_wsm6
       mphys_id='wsm6'
    case('wdm6')
       imphys=imphys_wdm6
       mphys_id='wdm6'
    case('4A')
       imphys=imphys_4A
       mphys_id='4A'
    case default
       print*, 'Mphys scheme not recognized: ', mphys_scheme
       print*, 'Did you mean:'
       print*, '   lem2.4?'
       print*, '   um7_3?'
       print*, '   tau_bin?'
       print*, '   thompson09?'
       print*, '   thompson07?'
       print*, '   morr_two_moment?'
       print*, '   wsm6?'
       print*, '   4A?'
       print*, '(NB not all available in release version)'
       stop
    end select

    if (trim(input_file)=='')l_input_file=.False.

    if (.not. l_input_file)ifiletype=itest_case

  end subroutine read_namelist

end module namelists


*dk,flp2to0b
      subroutine flp2to0b(it1,ipos1,it2,npoints,ntets)
C
C ######################################################################
C
C     PURPOSE -
C
C        This routine performs the 2-to-0 flip across a material
C        interface.
C
C     INPUT ARGUMENTS -
C
C        it1      - the first tetrahedron
C        ipos1    - the position of the common face in it1
C        it2      - the second tetrahedron
C
C     OUTPUT ARGUMENTS -
C
C         None
C
C     CHANGE HISTORY -
C
C        $Log: flp2to0b.f,v $
C        Revision 2.00  2007/11/05 19:45:55  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.10   30 Sep 2004 09:59:02   dcg
CPVCS    use iand in place of .and. with integer variables
CPVCS
CPVCS       Rev 1.9   05 Jan 2001 12:56:08   dcg
CPVCS    use dble in place of float so as not to lose digits
CPVCS
CPVCS       Rev 1.8   Wed Apr 05 13:34:22 2000   nnc
CPVCS    Minor source modifications required by the Absoft compiler.
CPVCS
CPVCS       Rev 1.7   Wed Apr 07 14:14:16 1999   dcg
CPVCS    use implitcit none
CPVCS
CPVCS       Rev 1.6   Wed Feb 03 15:23:40 1999   dcg
CPVCS    remove calls to fluxing routines and associated memory.
CPVCS
CPVCS       Rev 1.5   Wed Apr 23 11:36:02 1997   dcg
CPVCS    No change.
CPVCS
CPVCS       Rev 1.4   Mon Apr 14 16:48:42 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.3   12/02/94 15:05:32   het
CPVCS    Added an option for the "cmo" access functions
CPVCS
CPVCS
CPVCS       Rev 1.2   12/01/94 18:47:28   het
CPVCS    Added a data type to the "cmo" calles
CPVCS       and added the "cmo.h" include file.
CPVCS
CPVCS       Rev 1.1   11/17/94 21:51:54   het
CPVCS    Added include files for chydro, neibor, cmerge, comdict. Added calles and
CPVCS    pointer statements for current_mesh_object database access.
CPVCS
CPVCS       Rev 1.0   11/10/94 12:13:10   pvcs
CPVCS    Original version.
C
C ######################################################################
      implicit none
C
      include "cmo.h"
      include "chydro.h"
      include "neibor.h"
C
C ######################################################################
C

C  arguments (it1,ipos1,it2,npoints,ntets)
      integer it1,ipos1,it2,npoints,ntets

C variables
      integer nmulti
      parameter (nmulti = 200)
      integer ichain0(nmulti),imt0(nmulti)
      integer ipts(3),ix(3),jd(3),kd(3)

      integer l1,l2,l3,ione,it2x,length,icmotype,ierror,
     *  i,j,k,i1,i2,i3,i4,ier,it1sum,it2sum,ierrdum,
     *  ierrfls,jtemp,ipos2,imtx1,imtx2,ict,ipar,ktemp

      real*8 volit1,volit2,volume,crosx1,crosy1,crosz1
C
C ######################################################################
C
C     DEFINE THE STATEMENT FUNCTIONS NEEDED TO CALCULATE TET VOLUMES.
C
      crosx1(i,j,k)=(yic(j)-yic(i))*(zic(k)-zic(i))-
     *              (yic(k)-yic(i))*(zic(j)-zic(i))
      crosy1(i,j,k)=(xic(k)-xic(i))*(zic(j)-zic(i))-
     *              (xic(j)-xic(i))*(zic(k)-zic(i))
      crosz1(i,j,k)=(xic(j)-xic(i))*(yic(k)-yic(i))-
     *              (xic(k)-xic(i))*(yic(j)-yic(i))
      volume(i1,i2,i3,i4)=(xic(i4)-xic(i1))*crosx1(i1,i2,i3)+
     *                    (yic(i4)-yic(i1))*crosy1(i1,i2,i3)+
     *                    (zic(i4)-zic(i1))*crosz1(i1,i2,i3)
C
      character*8 if1,if2,if3,if4
C
C ######################################################################
C
C
C     ******************************************************************
C     FETCH MESH OBJECT NAME AND POINTER INFORMATION.
C
      if(icmoget.eq.1) then
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
      call cmo_get_info('imt1',cmo,ipimt1,length,icmotype,ierror)
      call cmo_get_info('xic',cmo,ipxic,length,icmotype,ierror)
      call cmo_get_info('yic',cmo,ipyic,length,icmotype,ierror)
      call cmo_get_info('zic',cmo,ipzic,length,icmotype,ierror)
      call cmo_get_info('itetclr',cmo,ipitetclr,length,icmotype,ier)
      call cmo_get_info('itet',cmo,ipitet,length,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,length,icmotype,ierror)
C
      endif
C
C
C     ******************************************************************
C     IF THE DEBUG FLAG IS TURNED ON THEN PRINT A SUMMARY OF THE FLIP.
C
      if(idebug.gt.1) then
        it1sum=itet(1,it1)+itet(2,it1)+itet(3,it1)+itet(4,it1)
        volit1=volume(itet(1,it1),itet(2,it1),itet(3,it1),itet(4,it1))
        it2sum=itet(1,it2)+itet(2,it2)+itet(3,it2)+itet(4,it2)
        volit2=volume(itet(1,it2),itet(2,it2),itet(3,it2),itet(4,it2))
        i1=itet(1,it1)
        i2=itet(2,it1)
        i3=itet(3,it1)
        i4=itet(4,it1)
        if1=' '
        if(jtet(1,it1).ge.mbndry) if1='*'
        if2=' '
        if(jtet(2,it1).ge.mbndry) if2='*'
        if3=' '
        if(jtet(3,it1).ge.mbndry) if3='*'
        if4=' '
        if(jtet(4,it1).ge.mbndry) if4='*'
        write(logdan,9000) 'flp2to0b',it1,'old=',
     *                     i1,if1,i2,if2,i3,if3,i4,if4,
     *                     it1sum,volit1
        call writloga('bat',0,logdan,0,ierrdum)
        i1=itet(1,it2)
        i2=itet(2,it2)
        i3=itet(3,it2)
        i4=itet(4,it2)
        if1=' '
        if(jtet(1,it2).ge.mbndry) if1='*'
        if2=' '
        if(jtet(2,it2).ge.mbndry) if2='*'
        if3=' '
        if(jtet(3,it2).ge.mbndry) if3='*'
        if4=' '
        if(jtet(4,it2).ge.mbndry) if4='*'
        write(logdan,9010) '        ',it2,'old=',
     *                     i1,if1,i2,if2,i3,if3,i4,if4,
     *                     it2sum,volit2
        call writloga('bat',0,logdan,0,ierrdum)
 9000   format(a8,' it1=',i8,1x,a4,4(i7,a1),i8,1x,1pe10.3)
 9010   format(a8,' it2=',i8,1x,a4,4(i7,a1),i8,1x,1pe10.3)
        call writfls('bat',ierrfls)
      endif
C
C     ******************************************************************
C     PERFORM THE FLIP.
C
      jtemp=jtet(ipos1,it1)-mbndry
      it2x=0.25*dble(jtemp)+0.9
      if (it2x.ne.it2) call termcode(1)
      ipos2=iand((jtemp-1),maskface)+1
C
      i1=itet(iflist(3*ipos1-2),it1)
      i3=itet(iflist(3*ipos1-1),it1)
      i2=itet(iflist(3*ipos1  ),it1)
      jd(1)=jtet(iflist(3*ipos1-2),it1)
      jd(3)=jtet(iflist(3*ipos1-1),it1)
      jd(2)=jtet(iflist(3*ipos1  ),it1)
C
C     ..................................................................
C
C     GET THE COUPLED CHAIN LISTS FOR THE THREE FACE POINTS.
C
      imtx1=imt1(i1)
      imtx2=imt1(itet1(jtemp))
      ipts(1)=i1
      ipts(2)=i2
      ipts(3)=i3
      do 50 i=1,3
         ix(i)=0
         call getchain(ipts(i),ichain0,imt0,nmulti,ict,ipar)
         do 40 k=1,ict
            if (imt0(k) .eq. imtx2) then
               ix(i)=ichain0(k)
               goto 50
            endif
 40      continue
 50   continue
      if (ix(1).eq.0 .or. ix(2).eq.0 .or. ix(3).eq.0) call termcode(1)
C
C     ..................................................................
C
C     DETERMINE THE ORIENTATION OF THE SECOND TETRAHEDRON.
C
      l1=iflist(3*ipos2-2)
      l2=iflist(3*ipos2-1)
      l3=iflist(3*ipos2)
                                kd(1)=jtet(l1,it2)
      if(itet(l2,it2).eq.ix(1)) kd(1)=jtet(l2,it2)
      if(itet(l3,it2).eq.ix(1)) kd(1)=jtet(l3,it2)
                                kd(2)=jtet(l1,it2)
      if(itet(l2,it2).eq.ix(2)) kd(2)=jtet(l2,it2)
      if(itet(l3,it2).eq.ix(2)) kd(2)=jtet(l3,it2)
                                kd(3)=jtet(l1,it2)
      if(itet(l2,it2).eq.ix(3)) kd(3)=jtet(l2,it2)
      if(itet(l3,it2).eq.ix(3)) kd(3)=jtet(l3,it2)
C
C     ..................................................................
C     MAKE THE 'jtet' ARRAY CONSISTENT.
C
      do 60 i=1,3
         jtemp=jd(i)
         ktemp=kd(i)
         if (jtemp .gt. mbndry) jtemp=jtemp-mbndry
         if (ktemp .gt. mbndry) ktemp=ktemp-mbndry
         if (jtemp.lt.mbndry .and. ktemp.lt.mbndry) then
            if (imt1(itet1(jtemp)) .eq. imt1(itet1(ktemp))) then
               if (jd(i) .gt. mbndry) jd(i)=jd(i)-mbndry
               if (kd(i) .gt. mbndry) kd(i)=kd(i)-mbndry
            else
               if (jd(i) .lt. mbndry) jd(i)=jd(i)+mbndry
               if (kd(i) .lt. mbndry) kd(i)=kd(i)+mbndry
            endif
            jtet1(jtemp)=kd(i)
            jtet1(ktemp)=jd(i)
         else
            if (jtemp .lt. mbndry) jtet1(jtemp)=kd(i)
            if (ktemp .lt. mbndry) jtet1(ktemp)=jd(i)
         endif
 60   continue
C
C
      nvacnt=nvacnt+2
      if(nvacnt.ge.lenvacnt) then
         ione=1
         lenvacnt=nvacnt+100
         call mflip(ione,lenvacnt,'ivacnt')
      endif
      ivacnt(nvacnt-1)=it1
      ivacnt(nvacnt)=it2
C
      if(idebug.gt.1) then
C*****  call tettestd
      endif
      goto 9999
 9999 continue
      return
      end


      SUBROUTINE SELAS2
C*****
C THIS ROUTINE IS PHASE II OF STRESS DATA RECOVERY FOR THE SCALAR SPRING
C ELEMENTS ELAS1, ELAS2, ELAS3 AND ELAS4.
C*****
C
C
C
C
C SDR2 VARIABLE CORE
C
      COMMON   /ZZZZZZ/  ZZ(1)
C
C BLOCK FOR POINTERS, LOADING TEMPERATURE AND ELEMENT DEFORMATION.
C
      COMMON   /SDR2X4/
     1                   DUMMY(33)          ,ICSTM
     2,                  NCSTM              ,IVEC
     3,                  IVECN              ,TEMPLD
     4,                  ELDEFM
C
C SDR2 INPUT AND OUTPUT BLOCK
C
      COMMON   /SDR2X7/
     1                   JELID              ,ISILNO(2)
     2,                  STIFF              ,SCOEFF
     3,                  XXXXXX(95)
     4,                  JSELID             ,STRESS
     5,                  YYYYYY(98)
     6,                  JFELID             ,FORCE
     7,                  ZZZZZZ(23)
      EQUIVALENCE
     1                   (SCOEFF,ICOEFF)
C
C
C
      IDISP = IVEC - 1
      DISP1 = 0.0
      DISP2 = 0.0
      IF (ISILNO(1) .LE. 0) GO TO 10
      IU = IDISP + ISILNO(1)
      DISP1 = ZZ(IU)
   10 IF (ISILNO(2) .LE. 0) GO TO 20
      IU = IDISP + ISILNO(2)
      DISP2 = ZZ(IU)
   20 JFELID = JELID
      FORCE = STIFF * (DISP1 - DISP2)
      IF (ICOEFF .EQ. (-1)) RETURN
      STRESS = SCOEFF * FORCE
      JSELID = JELID
      RETURN
      END