!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !MODULE:  m_mraob --- Implements RAOB Observation Metadata Stream
!
! !INTERFACE:
!
  module  m_mraob

! !USES:
  implicit none
!
! !PUBLIC TYPES:
      PRIVATE
      PUBLIC  raob_oms     ! ODS global metadata (kx names, etc.)
      PUBLIC  raob_rc      ! Returned status codes from read/write routines
!                          !   for each attribute
! !PUBLIC MEMBER FUNCTIONS:
      PUBLIC  mraob_init   ! allocates memory for OMS vector
      PUBLIC  mraob_clean  ! deallocates mmeory for OMS vector
      PUBLIC  mraob_get    ! reads OMS from file
      PUBLIC  mraob_put    ! writes OMS to file
      PUBLIC  mraob_map    ! maps ODS xm into OMS index
      PUBLIC  mraob_types  ! return list of WMO instrument types
      PUBLIC  mraob_radcor ! return list of WMO codes for radiation corr
!
! !DESCRIPTION:
!     This module implements the RAOB Observation Metadata Stream,
!
! !REVISION HISTORY:
!     15Nov2001  da Silva   First crack.
!     18Apr2002  Lucchesi   Added integer station ID
!     18Sep2002  C. Redder  Added character station ID (Id), station
!                           elevation (elev) and launch time (ltime) and
!                           removed integer station ID (istatn).  Made
!                           module privite.
!     10Oct2002  C. Redder  Added it_names (descriptive name for each
!                           intrument type) and rc_desc (description of
!                           all radcor codes) to the type raob_oms.  Added
!                           the publicly callable routine, nraob_types
!EOP
!-------------------------------------------------------------------------

! RAOB metadata type
! ------------------
  integer, parameter  :: DIdlen   =    8 ! String length of WMO station ID
  integer, parameter  :: NCR_MAX  =   63 ! Max no. of char in table entries
  integer, parameter  :: nsyn_Def =    4 ! Default for no syn time/day
  integer, parameter  :: nsta_Def = 2000 ! Default for no stations

  type raob_rc                           ! Return status code from the ODS
     integer          :: xm, Id, lat, &  !   read routine for each attribute
                                 lon, elev, itype, radcor, ltime
  end type raob_rc

  type raob_oms
     integer          :: nsta            ! No. of stations/reports
     integer          :: nvct            ! Max size of vectors
     integer          :: nsyn            ! No. synoptic time on file
     integer          :: Idlen           ! Length of WMO station ID
     integer          :: ntypes          ! No of WMO instrument types
     integer          :: nradcor         ! No of WMO radcor code
     integer          :: ncr             ! Actual no. of char in table entries
     character ( len = NCR_MAX ), pointer &
                      :: it_names (:)    ! Names of WMO intrument types.  Last
                                         !   entry is reserved for WMO type 0.
     character ( len = NCR_MAX ), pointer &
                      :: rc_descr (:)    ! Description of the WMO radcor codes.
                                         !   Last entry is for WMO code 0.
     real,    pointer :: xm       (:)    ! Metadata index
     character ( len = DIdlen  ), &
              pointer :: Id       (:)    ! WMO station Id
     real,    pointer :: lat      (:)    ! Latitude  (degrees) [-90,+90]
     real,    pointer :: lon      (:)    ! Longitude (degrees) [-180,+180]
     real,    pointer :: elev     (:)    ! Station elevation (m)
     integer, pointer :: itype    (:)    ! WMO instrument type indices
     integer, pointer :: radcor   (:)    ! WMO solar/IR correction codes
     integer, pointer :: ltime    (:)    ! Launch time (minutes since syn time)
     type (raob_rc)   :: rc              ! Returned status codes
  end type raob_oms
  character (len=*), parameter :: &
     AttList = 'xm,Id,lat,lon,elev,itype,radcor,ltime'

  integer, external   :: ods_julian, ods_caldat

! Interfaces
! ----------
  Interface Init
     module procedure MRAOB_Init
  end Interface
  Interface Clean
     module procedure MRAOB_Clean
  end Interface
  Interface Put
     module procedure MRAOB_Put
  end Interface

  Interface Get
     module procedure MRAOB_Get
  end Interface
  Interface Map
     module procedure MRAOB_Map
  end Interface

CONTAINS

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !IROUTINE:  MRAOB_Init --- Allocates necessary memory
!
! !INTERFACE:
  subroutine MRAOB_Init ( this, nsta,   rc, &
                          nsyn, ntypes, nradcor )
!
! !USES
  implicit NONE

! !INPUT PARAMETERS:
      integer, intent(in)            :: nsta    ! number of stations
      integer, intent(in), OPTIONAL  :: nsyn    ! no. syn times/day
      integer, intent(in), OPTIONAL  :: ntypes  ! no. instr type
      integer, intent(in), OPTIONAL  :: nradcor ! no. radcor codes

! !INPUT/OUTPUT PARAMETERS:
      type(raob_oms), intent(inout)  :: this    ! RAOB OMS

      integer, intent(out)           :: rc      ! Error return code:
                                                ! = 0    - all is well
!
! !DESCRIPTION:
!     This routine allocates memory for the data structure of type raob_oms.
!     This routine also initializes the file parameters and the file tables.
!
! !REVISION HISTORY:
!     07Apr2002  da Silva   First crack.
!     18Sep2002  C. Redder  Added character station ID (Id), station
!                           elevation (elev) and launch time (ltime) and
!                           removed integer station ID (istatn).
!     10Oct2002  C. Redder  Added optional argument, ntypes.  Added code
!                           to allocate and initialize tables.
!     18Oct2002  C. Redder  Fixed bug that inappropriately accesses the
!                           optional input parameters, ntypes and nradcor.
!EOP
!-------------------------------------------------------------------------

  character(len=*), parameter :: myname = 'mraob_init'
  integer ios, nnsta, nvct, nnsyn, iIdlen, nntypes, nnradcor

  rc = 0

! If optional parameters not specified, use default
! -------------------------------------------------
  if ( present ( nsyn    )) then
     nnsyn    = nsyn
  else
     nnsyn    = nsyn_Def
  end if

  if ( present ( ntypes  )) then
     nntypes  = ntypes
  else
     call MRaob_Types  ( nntypes  )
  end if

  if ( present ( nradcor )) then
     nnradcor = nradcor
  else
     call MRaob_RadCor ( nnradcor )
  end if

! Store file parameters
! ---------------------
  this % nsyn    = nnsyn
  this % Idlen   = DIdlen
  this % ntypes  = nntypes
  this % nradcor = nnradcor
  this % ncr     = NCR_Max

! Allocate memory for tables
! --------------------------
  allocate ( this % it_names ( nntypes  ), &
             this % rc_descr ( nnradcor ), &
             stat = ios )
  if ( ios .ne. 0 ) then
     rc = 1
     return
  end if

! Initialize tables
! -----------------
  call MRaob_Types  ( nntypes,  this % it_names )
  call MRaob_RadCor ( nnradcor, this % rc_descr )

! Check number of stations
! ------------------------
  nnsta = nsta
  if ( nsta < 0 ) nnsta = nsta_Def

! Allocate memory for station attributes
! --------------------------------------
  this % nsta = nnsta
  this % nvct = max ( 1, nnsta )
  nvct = this % nvct
  allocate ( this % xm       (nvct), &
             this % Id       (nvct), &
             this % lat      (nvct), &
             this % lon      (nvct), &
             this % elev     (nvct), &
             this % itype    (nvct), &
             this % radcor   (nvct), &
             this % ltime    (nvct), &
             stat = ios )
  if ( ios .ne. 0 ) then
       rc = 2
       deallocate ( this % it_names, &
                    this % rc_descr, &
                    stat = ios ) ! ignore status code
       return
  end if

! All done
! --------
  return

end subroutine MRAOB_Init

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !IROUTINE:  MRAOB_Clean --- Deallocates memory used by RAOB OMS
!
! !INTERFACE:
  subroutine MRAOB_Clean ( this, rc )

!
! !USES
  implicit NONE

! !INPUT/OUTPUT PARAMETERS:
      type(raob_oms), intent(inout) ::  this   ! RAOB OMS

! !OUTPUT PARAMETERS:
      integer,       intent(out)    ::  rc     ! Error return code:
                                               ! = 0    - all is well
!
! !DESCRIPTION: This routine allocates memory for RAOB OMS.
!
! !REVISION HISTORY:
!     07Apr2002  da Silva   First crack.
!     18Sep2002  C. Redder  Added character station ID (Id), station
!                           elevation (elev) and launch time (ltime) and
!                           removed integer station ID (istatn).
!     10Oct2002  C. Redder  Added code to clean up tables
!EOP
!-------------------------------------------------------------------------

  character(len=*), parameter :: myname = 'mraob_clean'
  integer ios

  rc = 0

! Reset file parameters
! ---------------------
  this % nsta    = 0
  this % nvct    = 0
  this % nsyn    = 0
  this % Idlen   = 0
  this % ntypes  = 0
  this % nradcor = 0
  this % ncr     = 0

! Deallocate memory for tables
! --------------------------
  deallocate ( this % it_names, &
               this % rc_descr, &
               stat = ios )
  if ( ios .ne. 0 ) rc = rc + 1

! Deallocate memory for station attributes
! ----------------------------------------
  deallocate ( this % xm,     &
               this % Id,     &
               this % lat,    &
               this % lon,    &
               this % elev,   &
               this % itype,  &
               this % radcor, &
               this % ltime,  &
               stat = ios )
  if ( ios .ne. 0 ) rc = rc + 2

! All done
! --------
  return

end subroutine MRAOB_Clean

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !IROUTINE:  MRAOB_Get --- Reads RAOB OMS for a given synoptic time
!
! !INTERFACE:
  subroutine MRAOB_Get ( fname, nymd, nhms, this, rc )

!
! !USES
  implicit NONE

! !INPUT PARAMETERS:
      character(len=*), intent(in)  :: fname ! OMS file name
      integer,          intent(in)  :: nymd  ! year-month-day, e.g., 19990701
      integer,          intent(in)  :: nhms  ! hour-min-sec,   e.g., 120000
!
! !OUTPUT PARAMETERS:
      type(raob_oms),   intent(inout) :: this ! RAOB OMS
      integer,          intent(out) :: rc    ! Error return code:
                                             !  0 - all is well
!
! !DESCRIPTION:
!     This routine reads metadata from a RAOB OMS file, allocates the
!     necessary memory for the OMS vector, and loads the data for the
!     synoptic time (nymd,nhms). Usually the OMS file is opened, the data
!     is read in and the file is closed.
!
! !REVISION HISTORY:
!     07apr2002  da Silva   Initial code.
!     18Sep2002  C. Redder  Added character station ID (Id), station
!                           elevation (elev) and launch time (ltime) and
!                           removed integer station ID (istatn).
!     10Oct2002  C. Redder  Added code to retrieve list of intrument types.
!     11Dec2002  Herdies    Turned "this" inout.
!     09Jan2003  C. Redder  Commented out the call to MRaob_Clean
!EOP
!-------------------------------------------------------------------------

  character(len=*), parameter :: myname = 'mraob_get'
  integer :: id, ier, nkt, nkt1, nkx, nqc, ncr, nsyn, nobs, khms
  integer :: jday, syn_hour, ods_nget, Idlen, ntypes, nradcor
  integer :: first_jday, first_nymd, first_nhms
  logical :: fexists, ODS_EGet, idexists, itexists, rcexists

  rc = 0

! Determine file ID
! -----------------
  inquire ( file=trim(fname), exist=fexists )
  if ( fexists ) then
     call ODS_Open ( id, fname, 'r', ier ) ! open the file
     if ( ier .ne. 0 ) then
        rc = 1
        return
     end if
  else
     rc = 1
     return
  end if

! Determine no synoptic times/day
! -------------------------------
  call ODS_IGet ( id, 'nsyn',   nsyn, ier ); if ( ier .ne. 0 ) rc = 2
  if ( rc .ne. 0 ) then
     call ODS_Close ( id, ' ', ier )
     return
  end if

! ... and string length of WMO station ID
! ---------------------------------------
  idexists = ODS_EGet  ( id, 'Idlen', ier ); if ( ier .ne. 0 ) rc = 2
  if ( rc .ne. 0 ) then
     call ODS_Close ( id, ' ', ier )
     return
  end if
  Idlen = DIdlen
  if ( idexists ) then
     call ODS_IGet ( id, 'Idlen', Idlen, ier ); if ( ier .ne. 0 ) rc = 2
     if ( rc .ne. 0 ) then
        call ODS_Close ( id, ' ', ier )
        return
     end if
  end if

! ... and the number of instrument types
! --------------------------------------
  itexists = ODS_EGet  ( id, 'ntypes', ier ); if ( ier .ne. 0 ) rc = 2
  if ( rc .ne. 0 ) then
     call ODS_Close ( id, ' ', ier )
     return
  end if
  call MRaob_Types ( ntypes )
  if ( itexists ) then
     call ODS_IGet ( id, 'ntypes', ntypes, ier ); if ( ier .ne. 0 ) rc = 2
     if ( rc .ne. 0 ) then
        call ODS_Close ( id, ' ', ier )
        return
     end if
  end if

! ... and the number of radcor codes
! ----------------------------------
  rcexists = ODS_EGet  ( id, 'nradcor', ier ); if ( ier .ne. 0 ) rc = 2
  if ( rc .ne. 0 ) then
     call ODS_Close ( id, ' ', ier )
     return
  end if
  call MRaob_RadCor ( nradcor )
  if ( rcexists ) then
     call ODS_IGet ( id, 'nradcor', nradcor, ier ); if ( ier .ne. 0 ) rc = 2
     if ( rc  .ne. 0 ) then
        call ODS_Close ( id, ' ', ier )
        return
     end if
  end if

! Determine how many obs in this synoptic time
! --------------------------------------------
  jday = ODS_Julian ( nymd )
  syn_hour = nhms / 10000
  nobs = ODS_NGet ( id, jday, syn_hour, ier )
  if ( ier .ne. 0 ) then
     rc = 3
     call ODS_Close ( id, ' ', ier )
     return
  end if

! No observations, nothing left to do
! -----------------------------------
  if ( nobs == 0 ) then
     call ODS_Close ( id, ' ', ier )
     call MRAOB_Init  ( this, nobs, ier )
     return
  end if

! Allocate memory for OMS file
! ----------------------------
!  call MRAOB_Clean ( this, ier )      ! ignore ier
  call MRAOB_Init  ( this, nobs, ier, nsyn    = nsyn,   &
                                      ntypes  = ntypes, &
                                      nradcor = nradcor )
  if ( ier .ne. 0 ) then
     rc = 4
     call ODS_Close ( id, ' ', ier )
     return
  end if

! Read in OMS file tables
! -----------------------
  if ( idexists ) then
     call ODS_GetList ( id, 'it_names', ntypes,  this % it_names, ier )
     if ( ier .ne. 0 ) rc = 5
  end if
  if ( rcexists ) then
     call ODS_GetList ( id, 'rc_descr', nradcor, this % rc_descr, ier )
     if ( ier .ne. 0 ) rc = 5
  end if
  if ( rc .ne. 0 ) then
     call ODS_Close ( id, ' ', ier )
     return
  end if

! Read in OMS attributes
! ----------------------
  call ODS_GetR ( id, 'xm',     jday, syn_hour, nobs, this % xm,     ier )
  this % rc % xm       = ier
  if ( ier .ne. 0 ) rc = 6
  call ODS_GetC ( id, 'Id',     jday, syn_hour, nobs, this % Id,     ier )
  this % rc % Id       = ier
  if ( ier .ne. 0 ) rc = 6
  call ODS_GetR ( id, 'lat',    jday, syn_hour, nobs, this % lat,    ier )
  this % rc % lat      = ier
  if ( ier .ne. 0 ) rc = 6
  call ODS_GetR ( id, 'lon',    jday, syn_hour, nobs, this % lon,    ier )
  this % rc % lon      = ier
  if ( ier .ne. 0 ) rc = 6
  call ODS_GetR ( id, 'elev',   jday, syn_hour, nobs, this % elev,   ier )
  this % rc % elev     = ier
  if ( ier .ne. 0 ) rc = 6
  call ODS_GetI ( id, 'itype',  jday, syn_hour, nobs, this % itype,  ier )
  this % rc % itype    = ier
  if ( ier .ne. 0 ) rc = 6
  call ODS_GetI ( id, 'radcor', jday, syn_hour, nobs, this % radcor, ier )
  this % rc % radcor   = ier
  if ( ier .ne. 0 ) rc = 6
  call ODS_GetI ( id, 'ltime',  jday, syn_hour, nobs, this % ltime,  ier )
  this % rc % ltime    = ier
  if ( ier .ne. 0 ) rc = 6

! Close the file if we have opened it
! -----------------------------------
  call ODS_Close ( id, ' ', ier )
  if ( rc .ne. 0 ) return

! All done
! --------
  rc = 0
  return

  end subroutine mraob_get

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !IROUTINE:  MRAOB_Put --- Writes RAOB OMS for a given synoptic time
!
! !INTERFACE:
  subroutine MRAOB_Put ( fname, nymd, nhms, this, rc, &
                         append, new )

!
! !USES
  implicit NONE

! !INPUT PARAMETERS:
      character(len=*),  intent(in)  :: fname  ! OMS file name
      integer,           intent(in)  :: nymd   ! year-month-day, e.g. 19990701
      integer,           intent(in)  :: nhms   ! hour-min-sec,   e.g. 120000

      type(raob_oms),    intent(in)  :: this   ! RAOB OMS
      logical, optional, intent(in)  :: append ! If true, the data is appended
                                               ! to the OMS file at this time.
                                               ! Default: append = .false.

      logical, optional, intent(in)  :: new    ! If true, file will be created
                                               ! whether it exists or not
                                               ! Default: new    = .false.
!
! !OUTPUT PARAMETERS:
       integer,          intent(out) :: rc     ! Error return code:
                                               !  0 - all is well

! !DESCRIPTION:
!     This routine writes metadata to a RAOB OMS file on a given synoptic
!     time. Usually the OMS file is opened, the metadata is written to
!     the file is closed.
!
! !REVISION HISTORY:
!     07apr2002  da Silva   Initial code.
!     18Sep2002  C. Redder  Added character station ID (Id), station
!                           elevation (elev) and launch time (ltime) and
!                           removed integer station ID (istatn).
!     10Oct2002  C. Redder  Added code to process list of intrument types.
!     10Nov2002  C. Redder  Bug fix - initialized rc at the beginning.
!EOP
!-------------------------------------------------------------------------

  character(len=*), parameter :: myname = 'mraob_put'

  integer :: ier, ier2, id, jday, syn_hour
  integer :: nobs, nsyn, Idlen, ntypes, nradcor, ncr
  integer :: first_jday, first_nymd, first_nhms
  integer :: ods_nget, NObs_Init
  logical :: appending, fexists, creating

  rc = 0

! Handle optional parameters
! --------------------------
  id = -1
  if ( present(append) ) then
     appending = append
  else
     appending = .false.
  end if
  if ( present(new) ) then
       creating = new
  else
       creating = .false.
  end if

! Check whether file exists
! -------------------------
  inquire ( file=trim(fname), exist=fexists )

! Open ...
! --------
  jday = ods_julian ( nymd )
  syn_hour = nhms / 10000
  nobs = this%nsta
  if ( (id .lt. 0 .and. fexists) .AND. (.not. creating) ) then
     call ODS_Open ( id, fname, 'w', ier ) ! open the file
     if ( ier .ne. 0 ) then
        rc = 1
        return
     end if

!    ... and determine the first date and time on file
!    -------------------------------------------------
     call ODS_IGet ( id, 'syn_beg:first_julian_day', first_jday, ier )
     if ( ier .ne. 0 ) then
        rc = 8
        call ODS_Close ( id, ' ', ier )
        return

     end if
     first_nymd = ODS_CalDat ( first_jday )
     first_nhms = 0

! or Create
! ---------
  else if ( id .lt. 0 .or. creating ) then

     nsyn    = this % nsyn
     Idlen   = this % Idlen
     ntypes  = this % ntypes
     nradcor = this % nradcor
     ncr     = this % ncr
     call ODS_SetParmI   ( 'nsyn',    nsyn,    ier )
     if ( ier .ne. 0 ) then
        rc = 2
        return
     end if
     call ODS_SetParmI   ( 'Idlen',   Idlen,   ier )
     if ( ier .ne. 0 ) then
        rc = 2
        return
     end if
     call ODS_SetParmI   ( 'ntypes',  ntypes,  ier )
     if ( ier .ne. 0 ) then
        rc = 2
        return
     end if
     call ODS_SetParmI   ( 'nradcor', nradcor, ier )
     if ( ier .ne. 0 ) then
        rc = 2
        return
     end if
     call ODS_SetParmI   ( 'strlen',  ncr,     ier )
     if ( ier .ne. 0 ) then
        rc = 2
        return
     end if
     call MRAOB_Create   ( id, fname, jday,    ier )
     if ( ier /= 0 ) then
        rc = 8
        return
     end if
     call ODS_PutList    ( id, 'it_names', ntypes,  this % it_names, ier )
     if ( ier /= 0 ) then
        rc = 9
        return
     end if
     call ODS_PutList    ( id, 'rc_descr', nradcor, this % rc_descr, ier )
     if ( ier /= 0 ) then
        rc = 9
        return
     end if

     first_nymd = nymd
     first_nhms = 0

  end if

! Determine the number of ob reports already on file
! --------------------------------------------------
  NObs_Init = ODS_NGet ( id, jday, syn_hour, ier )
  if ( ier .ne. 0 ) then
     rc = 7
     call ODS_Close ( id, ' ', ier )
     return
  end if

! If appending to this synoptic time, do the
! setup (if ob reports are already on file)
! ------------------------------------------
  if ( appending .and. NObs_Init .gt. 0 ) then

     call ODS_Append ( id, nobs, ier )
     if ( ier .ne. 0 ) then
        rc = 3
        call ODS_Close ( id, ' ', ier )
        return
     end if
  end if

! OK, now we are ready for the heavy duty writing
! -----------------------------------------------
  call ODS_PutR ( id, 'xm',     jday, syn_hour, nobs, this % xm,     ier )
  if ( ier .ne. 0 ) rc = 4
  call ODS_PutC ( id, 'Id',     jday, syn_hour, nobs, this % Id,     ier )
  if ( ier .ne. 0 ) rc = 4
  call ODS_PutR ( id, 'lat',    jday, syn_hour, nobs, this % lat,    ier )
  if ( ier .ne. 0 ) rc = 4
  call ODS_PutR ( id, 'lon',    jday, syn_hour, nobs, this % lon,    ier )
  if ( ier .ne. 0 ) rc = 4
  call ODS_PutR ( id, 'elev',   jday, syn_hour, nobs, this % elev,   ier )
  if ( ier .ne. 0 ) rc = 4
  call ODS_PutI ( id, 'itype',  jday, syn_hour, nobs, this % itype,  ier )
  if ( ier .ne. 0 ) rc = 4
  call ODS_PutI ( id, 'radcor', jday, syn_hour, nobs, this % radcor, ier )
  if ( ier .ne. 0 ) rc = 4
  call ODS_PutI ( id, 'ltime',  jday, syn_hour, nobs, this % ltime,  ier )
  if ( ier .ne. 0 ) rc = 4

! Close the file if user is not doing the file management
! -------------------------------------------------------
  call ODS_Close ( id, ' ', ier )
  if ( rc .ne. 0 ) return

! All done
! --------
  end subroutine mraob_put

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !IROUTINE:  MRAOB_Map --- Maps ODS xm into OMS index
!
! !INTERFACE:

  subroutine MRAOB_Map ( nobs, xm, this, ioms, rc )

!
! !USES
!
  implicit NONE

! !INPUT PARAMETERS:
!
      integer,        intent(in)  :: nobs       ! size of XM vector
      real,           intent(in)  :: xm(nobs)   ! ODS metadata index
      type(raob_oms), intent(in)  :: this       ! RAOB OMS

!
! !OUTPUT PARAMETERS:
!
      integer,        intent(out) :: ioms(nobs) ! OMS index (same size as XM)
      integer,        intent(out) :: rc         ! Error return code:
                                                !  0 - all is well

! !DESCRIPTION:
!     This routine translates the ODS metadata index XM into the OMS
!     metadata index IOMS. With this index, one can address the OMS
!     vector directory, say, this%itype(ioms(i)).
!
! !REVISION HISTORY:
!     07Apr2002  da Silva   Initial code.
!     25Apr2002  C Redder   Fixed compilation error (idx renamed to indx).
!
!EOP
!-------------------------------------------------------------------------

  character(len=*), parameter :: myname = 'mraob_map'
  integer, allocatable :: indx(:)
  integer ios, n, i
  real, parameter :: TOL = 0.001

  rc = 0
  n = this%nvct
  allocate ( indx(n), stat = ios )
  if ( ios .ne. 0 ) then
     rc = 1
     return
  end if
  indx = (/ ( i, i = 1, this%nvct ) /)

! Match XM with each station
! --------------------------
  do i = 1, this%nsta
     where ( abs ( xm - this%xm(i) ) < TOL ) ioms = indx(i)
  end do

  deallocate ( indx )

  end subroutine mraob_map

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !IROUTINE:  PrepList --- Chaeck and prepare list of attributes
!
! !INTERFACE:

  function PrepList ( List )

!
! !USES
!

! !INPUT PARAMETERS:
      implicit NONE
      character (len=*), intent (in)  :: List      ! input list
!
! !OUTPUT PARAMETERS:
      character (len=len(List))       :: PrepList  ! Modified list

! !DESCRIPTION:
!     Checks and prepares list of attributes by stripping out intermediate
!     blanks, and removing duplicate entries and unnecessary commas.  If a
!     list entry is invalid, then a blank string is returned.  This
!     function is low-level
!
! !REVISION HISTORY:
!     24Sep2002  C Redder   Initial code.
!
!EOP
!-------------------------------------------------------------------------
  integer :: iCh1, iCh2, iCh2_Next, NCh1, LVar
  character (len=len(List)) :: Var
  character (len=1) :: Ch1

  PrepList = ' '
  NCh1     = len_trim ( List )
  LVar     = 0
  iCh2     = 1
  do iCh1 = 1, NCh1 + 1                ! Add list entry delimeter to end of
     Ch1 = ','                         !   list to process last entry
     if ( iCh1 .le. NCh1 ) Ch1 = List ( iCh1 : iCh1 )
     if (  Ch1 .ne. ' '  ) then        ! Skip over blanks
     if (  Ch1 .ne. ','  ) then        ! If not list entry delimiter
        LVar = LVar + 1                !    then add character to variable
        Var ( LVar : LVar ) = Ch1      !    name stored in scratch space
     else                              ! Else ...
        if ( LVar .gt. 0 ) then        !    If entry is not valid ...
           if      ( .not. in_list ( Var      ( : LVar ), &
                                     AttList )) then
              PrepList  = ' '          !    ... return with blank string
              return
           else if ( .not. in_list ( Var      ( : LVar ), &
                                     PrepList ( : iCh2 - 1 ))) then
                                       ! Skip over duplicate entries
              if ( iCh2 .gt. 1 ) then  ! If not first entry then
                 PrepList ( iCh2 : iCh2 ) = ','
                 iCh2   = iCh2 + 1     ! ... add preceding comma.
              end if
              iCh2_Next = iCh2 + LVar  ! ... to each entry in the output list.
              PrepList ( iCh2 : iCh2_Next - 1 ) = Var ( : LVar )
              iCh2      = iCh2_Next
           end if
        end if
        LVar      = 0

     end if
     end if
  end do

  return

  contains

!    Internal function for determining if given entry exists in the list
!    -------------------------------------------------------------------
     logical function in_list ( Var, List )
     implicit NONE
     character (len=*), intent(in) :: Var, List
     in_list = index ( ',' // List // ',', &
                       ',' // Var  // ',' ) .gt. 0
     return
     end function in_list
  end function PrepList

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !IROUTINE:  MRaob_Types - Define list of radiosonde instrument types
!
! !INTERFACE:
!
      subroutine MRaob_Types ( NTypes, List )

! !USES:
      implicit none

! !OUTPUT PARAMETERS:
      integer,           intent (out), optional :: &
         NTypes          ! Number of entries in the table
      character (len=*), intent (out), dimension (:), optional :: &
         List            ! Discription of each radiosonde instrument type

! !DESCRIPTION:
!%    \label{MODS:RaobTypes}
!     Returns the number of WMO radiosonde instrument types and, if, desired
!     the description of each type.  WMO code of 0 is assumed to be
!     NTypes, since the lower bounds of the output array is assumed to
!     be 1.
!
!    !REVISION HISTORY:
!     21Sep2001  C Redder  Orininal code
!     10Oct2002  C Redder  Adapted from module m_RaobMeta
!     27May2003  R Todling Bug fix: continuation line set incorrectly
!
!EOP
!-------------------------------------------------------------------------
  integer :: iType, NNTypes
  integer, parameter :: TypeMax = 256   ! Maximum value for raob type
  character (len=*), parameter, dimension (TypeMax) :: TypeList = (/ &
    ! Description                                                 ! Code
    ! -----------                                                 ! ----
     'Reserved                                                 ', & ! 1
     'No radiosonde - passive target (e.g. reflector)          ', & ! 2
     'No radiosonde - active target (e.g. transponder)         ', & ! 3
     'No radiosonde - passive temperature-humidity profiler    ', & ! 4
     'No radiosonde - active temperature-humidity profiler     ', & ! 5
     'No radiosonde - active radio-acoustic sounder            ', & ! 6
     'No radiosonde - ...(reserved)                            ', & ! 7
     'No radiosonde - ...(reserved)                            ', & ! 8
     'No radiosonde - system unknown or not specified          ', & ! 9
     'VIZ type A pressure-commutated (USA)                     ', & ! 10
     'VIZ type B time-commutated (USA)                         ', & ! 11
     'RS SDC (Space Data Corporation - USA)                    ', & ! 12
     'Astor (no longer made - Australia)                       ', & ! 13
     'VIZ Mark I MICROSONDE (USA)                              ', & ! 14
     'EEC Company type 23 (USA)                                ', & ! 15
     'Elin (Austria)                                           ', & ! 16
     'Graw G. (Germany)                                        ', & ! 17
     'Reserved for allocation of radiosonde                    ', & ! 18
     'Graw M60 (Germany)                                       ', & ! 19
     'Indian Meteorological Service MK3 (India)                ', & ! 20
     'VIZ/Jin Yang Mark I MICROSONDE (South Korea)             ', & ! 21
     'Meisei RS2-80 (Japan)                                    ', & ! 22
     'Mesural FMO 1950A (France)                               ', & ! 23
     'Mesural FMO 1945A (France)                               ', & ! 24
     'Mesural MH73A (France)                                   ', & ! 25
     'Meteolabor Basora (Switzerland)                          ', & ! 26
     'AVK-MRZ (Russian Federation)                             ', & ! 27
     'Meteorit Marz2-1 (Russian Federation)                    ', & ! 28
     'Meteorit Marz2-2 (Russian Federation)                    ', & ! 29
     'Oki RS2-80 (Japan)                                       ', & ! 30
     'VIZ/Valcom type A pressure-commutated (Canada)           ', & ! 31
     'Shanghai Radio (China)                                   ', & ! 32
     'UK Met Office MK3 (UK)                                   ', & ! 33
     'Vinohrady (Czechoslovakia)                               ', & ! 34
     'Vaisala RS18 (Finland)                                   ', & ! 35
     'Vaisala RS21 (Finland)                                   ', & ! 36
     'Vaisala RS80 (Finland)                                   ', & ! 37
     'VIZ LOCATE Loran-C (USA)                                 ', & ! 38
     'Sprenger E076 (Germany)                                  ', & ! 39
     'Sprenger E084 (Germany)                                  ', & ! 40
     'Sprenger E085 (Germany)                                  ', & ! 41
     'Sprenger E086 (Germany)                                  ', & ! 42
     'AIR IS - 4A - 1680 (USA)                                 ', & ! 43
     'AIR IS - 4A - 1680 X (USA)                               ', & ! 44
     'RS MSS (USA)                                             ', & ! 45
     'Air IS - 4A - 403 (USA)                                  ', & ! 46
     'Meisei RS2-91 (Japan)                                    ', & ! 47
     'VALCOM (Canada)                                          ', & ! 48
     'VIZ MARK II (USA)                                        ', & ! 49
     'GRAW DFM-90 (Germany)                                    ', & ! 50
     'VIZ-B2 (USA)                                             ', & ! 51
     'Vaisala RS80-57H                                         ', & ! 52
     'AVK-RF93 (Russian Federation)                            ', & ! 53
    ('Reserved for allocation of radiosondes                   ', & ! 54
      iType = 1, 6),                                              & !-59
     'Vaisala RS80/MicroCora (Finland)                         ', & ! 60
     'Vaisala RS80/DifiCora or Marwin (Finland)                ', & ! 61
     'Vaisala RS80/PCCora (Finland)                            ', & ! 62
     'Vaisala RS80/Star (Finland)                              ', & ! 63
     'Orbital Sciences Corporation, Space Data Division        ', & ! 64
     'VIZ transponder radiosonde, model number 1499-520 (USA)  ', & ! 65
    ('Reserved for additional automated sounding systems       ', & ! 66-
      iType = 1, 5),                                              & ! 70
     'RS90/MicroCora (Finland)                                 ', & ! 71
     'RS90/DigiCora or Marwin (Finland)                        ', & ! 72
     'RS90/PCCora (Finland)                                    ', & ! 73
     'RS90/Star (Finland)                                      ', & ! 74
     'AVK-MRZ-ARMA (Russian Federation)                        ', & ! 75
     'AVK-RF95-ARMA (Russian Federation)                       ', & ! 76
     'GEOLINK GPSonde GL98 (France)                            ', & ! 77
    ('Reserved for additional automated sounding systems       ', & ! 78-
      iType = 1, 12),                                             & ! 89
     'Radiosonde not specified or unknownd                     ', & ! 90
     'Pressure-only radiosonde                                 ', & ! 91
     'Pressure-only radiosonde plus transponder                ', & ! 92
     'Pressure-only radiosonde plus radar reflector            ', & ! 93
     'No-pressure-only radiosonde plus transponder             ', & ! 94
     'No-pressure-only radiosonde plus radar reflector         ', & ! 95
     'Descending radiosonde                                    ', & ! 96
    ('Reserved for sounding systems with incomplete sondes     ', & ! 97-
      iType = 1, 3),                                              & ! 99
    ('Reserved                                                 ', & ! 100-
      iType = 1, 155),                                            & ! 254
     'Missing value                                            ', & ! 255
     'Reserved (Same as WMO code 0)                            '/)  ! 256

  if ( present ( NTypes )) NTypes = size ( TypeList )
  if ( present ( List   )) then
     NNTypes = size ( List )
     NNTypes = min ( size ( TypeList ), size ( List ))
     List  ( : NNTypes ) &
             = TypeList ( : NNTypes )
     if ( NNTypes .lt. size ( List )) List ( NNTypes + 1 : ) = ' '
  end if

  return
  end subroutine MRaob_Types

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !IROUTINE:  MRaob_RadCor - Define list of WMO codes for radiation correction
!
! !INTERFACE:
!
      subroutine MRaob_RadCor ( NRadCor, Descr )

! !USES:
      implicit none

! !OUTPUT PARAMETERS:
      integer,           intent (out), optional :: &
         NRadCor         ! Number of entries in the table
      character (len=*), intent (out), dimension (:), optional :: &
         Descr           ! Discription of each radiosonde instrument type

! !DESCRIPTION:
!%    \label{MODS:RaobTypes}
!     Returns the number of WMO radiosonde bias codes and, if, desired
!     the description of each type.  WMO code of 0 is assumed to be
!     NRadCor, since the lower bounds of the output array is assumed to
!     be 1.
!
!    !REVISION HISTORY:
!     10Sep2002  C Redder  Orininal code
!     27May2003  R Todling Bug fix: continuation line set incorrectly
!
!EOP
!-------------------------------------------------------------------------
  integer :: iRadCor, NNRadCor
  integer, parameter :: RadCorMax = 16    ! Maximum value for radcor code
  character (len=*), parameter, dimension (RadCorMax) :: RadCorDescr = (/ &
  ! Description                                                         ! Code
  ! -----------                                                         ! ----
   'CIMO solar corrected and CIMO infrared corrected               ', & ! 1
   'CIMO solar corrected and infrared corrected                    ', & ! 2
   'CIMO solar corrected                                           ', & ! 3
   'Solar and infrared corrected automatically by radiosonde system', & ! 4
   'Solar corrected automatically by radiosonde system             ', & ! 5
   'Solar and infrared corrected as specified by country           ', & ! 6
   'Solar corrected as specified by country                        ', & ! 7
  ('Reserved                                                       ', & ! 8-
    iRadCor = 1, 7),                                                  & ! 14
   'Missing value                                                  ', & ! 15
   'No correction (Same as WMO code 0)                             '/)  ! 16

  if ( present ( NRadCor )) NRadCor = size ( RadCorDescr )
  if ( present ( Descr   )) then
     NNRadCor = min ( size ( RadCorDescr ), size ( Descr ))
     Descr ( : NNRadCor ) &
              = RadCorDescr ( : NNRadCor )
     if ( NNRadCor .lt. size ( Descr )) Descr ( NNRadCor + 1 : ) = ' '
  end if

  return
  end subroutine MRaob_RadCor
end module m_mraob


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      SUBROUTINE DECPC5 ( PMSA   , FL     , IPOINT , INCREM , NOSEG  ,
     +                    NOFLUX , IEXPNT , IKNMRK , NOQ1   , NOQ2   ,
     +                    NOQ3   , NOQ4   )

!
!     Description of the module :
!
!        General water quality module for DELWAQ:
!        Mineralization and conversion of fast decomposing detritus
!        Carbon, Nitrogen and Phosphorus.
!        Mineralization for nutrients can be faster than for C.
!        Hence C:N and C:P in slow detr. can be higher than in fast detr
!        POC, PON, and POP refer to slow detritus.
!
! Name    T   L I/O   Description                                   Units
! ----    --- -  -    -------------------                            ----
! POC     R*4 1 I     concentratrion of detritus C                [gC/m2]
! PON     R*4 1 I     concentratrion of detritus N                [gN/m2]
! POP     R*4 1 I     concentratrion of detritus P                [gP/m2]
! POS     R*4 1 I     concentratrion of detritus S                [gS/m2]
! RC20LO  R*4 1 I     degradation rate at 20 oC, lower value      [1/day]
! RC20UP  R*4 1 I     degradation rate at 20 oC, upper value      [1/day]
! RC20    R*4 1 I     degradation rate at 20 oC                   [1/day]
! TEMP    R*4 1 I     temperature                                    [oC]
! TC      R*4 1 I     temperature coefficient                         [-]
! TEMPC   R*4 1 -     temperature function                            [-]
! ANR     R*4 1 I     nitrogen content of refractory detritus     [gN/gC]
! APR     R*4 1 I     phosphorus content of refractory detritus   [gP/gC]
! ASR     R*4 1 I     sulfur content of refractory detritus       [gS/gC]
! ALN     R*4 1 I     nitrogen content of detritus, lower value   [gN/gC]
! ALP     R*4 1 I     phosphorus content of detritus, lower value [gN/gC]
! AUN     R*4 1 I     nitrogen content of detritus, upper value   [gN/gC]
! AUP     R*4 1 I     phosphorus content of detritus, upper value [gN/gC]
! FNUT    R*4 1 -     limiting factor for nutrient availability       [-]
! N_FACT  R*4 1 -     accelleration factor for nitrogen               [-]
! P_FACT  R*4 1 -     accelleration factor for phosphorus             [-]
! S_FACT  R*4 1 -     accelleration factor for sulphur                [-]
! OXY     R*4 1 I     concentratrion of dissolved oxygen         [gO2/m3]
! NO3     R*4 1 I     concentratrion of nitrate                   [gN/m3]
! B_NO3   R*4 1 I     attenuation constant for denitrification        [-]
! B_SULF  R*4 1 I     attenuation constant for sulfate reduction      [-]
! ELFACT  R*4 1 -     attenuation factor for electron acceptor        [-]
! B_DTPR  R*4 1 I     conversion ratio for part. refr. detritus       [-]
! B_DTDR  R*4 1 I     conversion ratio for diss. refr. detritus       [-]
! DECOC   R*4 1 O     degradation flux for detritus C         [gC/m3/day]
! DECON   R*4 1 O     degradation flux for detritus N         [gN/m3/day]
! DECOP   R*4 1 O     degradation flux for detritus P         [gP/m3/day]
! CNVOC   R*4 1 O     conversion flux for part. detritus C    [gC/m3/day]
! CNVON   R*4 1 O     conversion flux for part. detritus N    [gN/m3/day]
! CNVOP   R*4 1 O     conversion flux for part. detritus P    [gP/m3/day]
! CNVDC   R*4 1 O     conversion flux for diss. detritus C    [gC/m3/day]
! CNVDN   R*4 1 O     conversion flux for diss. detritus N    [gN/m3/day]
! CNVDP   R*4 1 O     conversion flux for diss. detritus P    [gP/m3/day]
! DECOCE  R*4 1 O     degradation flux for detritus C emersed [gC/m3/day]
! DEPTH   R*4 1 O     depth of segment                               [m3]
! NATTEM  R*4 1 O     air temperature                                [oC]
! SWEMRS  I*4 1 O     switch for emersion                             [-]

!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------

      IMPLICIT REAL (A-H,J-Z)

      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4

      REAL     POC    , PON   , POP   , RC20LO , RC20UP , RC20   ,
     +         TEMP   , TC    , TEMPC , ANR    , APR    , ALN    ,
     +         ALP    , AUN   , AUP   , FNUT   , N_FACT , P_FACT ,
     +         OXY    , NO3   , B_NO3 , B_SULF , ELFACT , B_DTPR ,
     +         B_DTDR , DECOC , DECON , DECOP  , CNVPC  , CNVPN  ,
     +         CNVPP  , CNVDC , CNVDN , CNVDP  , POS    , DECOS  ,
     +         CNVPS  , CNVDS , ASR   , S_FACT , DEPTH  , NATTEM ,
     +         DECOCE
      INTEGER  SWEMRS
!
      IP1  = IPOINT( 1)
      IP2  = IPOINT( 2)
      IP3  = IPOINT( 3)
      IP4  = IPOINT( 4)
      IP5  = IPOINT( 5)
      IP6  = IPOINT( 6)
      IP7  = IPOINT( 7)
      IP8  = IPOINT( 8)
      IP9  = IPOINT( 9)
      IP10 = IPOINT(10)
      IP11 = IPOINT(11)
      IP12 = IPOINT(12)
      IP13 = IPOINT(13)
      IP14 = IPOINT(14)
      IP15 = IPOINT(15)
      IP16 = IPOINT(16)
      IP17 = IPOINT(17)
      IP18 = IPOINT(18)
      IP19 = IPOINT(19)
      IP20 = IPOINT(20)
      IP21 = IPOINT(21)
      IP22 = IPOINT(22)
      IP23 = IPOINT(23)
      IP24 = IPOINT(24)
      IP25 = IPOINT(25)
      IP26 = IPOINT(26)
      IP27 = IPOINT(27)
      IP28 = IPOINT(28)
      IP29 = IPOINT(29)

      IN1  = INCREM( 1)
      IN2  = INCREM( 2)
      IN3  = INCREM( 3)
      IN4  = INCREM( 4)
      IN5  = INCREM( 5)
      IN6  = INCREM( 6)
      IN7  = INCREM( 7)
      IN8  = INCREM( 8)
      IN9  = INCREM( 9)
      IN10 = INCREM(10)
      IN11 = INCREM(11)
      IN12 = INCREM(12)
      IN13 = INCREM(13)
      IN14 = INCREM(14)
      IN15 = INCREM(15)
      IN16 = INCREM(16)
      IN17 = INCREM(17)
      IN18 = INCREM(18)
      IN19 = INCREM(19)
      IN20 = INCREM(20)
      IN21 = INCREM(21)
      IN22 = INCREM(22)
      IN23 = INCREM(23)
      IN24 = INCREM(24)
      IN25 = INCREM(25)
      IN26 = INCREM(26)
      IN27 = INCREM(27)
      IN28 = INCREM(28)
      IN29 = INCREM(29)

      IFLUX = 0
!
      DO 9000 ISEG = 1 , NOSEG
!
!       In all active dry or wet segments
!
        CALL DHKMRK(3,IKNMRK(ISEG),IKMRK3)

        IF (IKMRK3.EQ.1 .OR. IKMRK3.EQ.3) THEN
!
!          INPUT of subroutine
!
           POC    = MAX(PMSA(IP1),0.0)
           PON    = MAX(PMSA(IP2),0.0)
           POP    = MAX(PMSA(IP3),0.0)
           POS    = MAX(PMSA(IP4),0.0)
           RC20UP = PMSA(IP5)
           RC20LO = PMSA(IP6)
           TC     = PMSA(IP7)
           TEMP   = PMSA(IP8)
           ANR    = PMSA(IP9)
           APR    = PMSA(IP10)
           ASR    = PMSA(IP11)
           ALN    = PMSA(IP12)
           ALP    = PMSA(IP13)
           AUN    = PMSA(IP14)
           AUP    = PMSA(IP15)
           OXY    = PMSA(IP16)
           NO3    = PMSA(IP17)
           B_NO3  = PMSA(IP18)
           B_SULF = PMSA(IP19)
           B_DTPR = PMSA(IP20)
           B_DTDR = PMSA(IP21)
           DEPTH  = PMSA(IP22)
           SWEMRS = NINT(PMSA(IP23))
           NATTEM = PMSA(IP24)
           POC    = POC/DEPTH
           PON    = PON/DEPTH
           POP    = POP/DEPTH
           POS    = POS/DEPTH
!
!          Errors if certain vars =< 0
!
           IF (ANR .LT. 1E-30) CALL ERRSYS ('DECPC5: a_dNpr =< 0', 1 )
           IF (APR .LT. 1E-30) CALL ERRSYS ('DECPC5: a_dPpr =< 0', 1 )
           IF (ASR .LT. 1E-30) CALL ERRSYS ('DECPC5: a_dSpr =< 0', 1 )
           IF (ALN .LT. 1E-30) CALL ERRSYS ('DECPC5: al_dNs =< 0', 1 )
           IF (ALP .LT. 1E-30) CALL ERRSYS ('DECPC5: al_dPs =< 0', 1 )
           IF (AUN .LT. 1E-30) CALL ERRSYS ('DECPC5: au_dNs =< 0', 1 )
           IF (AUP .LT. 1E-30) CALL ERRSYS ('DECPC5: au_dPs =< 0', 1 )
!
!          Errors if upper limits =< lower limits
!
           IF (AUN .LE. ALN) CALL ERRSYS ('DECPC5: au_dNs =< al_dNs ',1)
           IF (AUP .LE. ALP) CALL ERRSYS ('DECPC5: au_dPs =< al_dPs ',1)
           IF (RC20UP .LT. RC20LO)
     &     CALL ERRSYS ('DECPC5: ku_dSdec20 < kl_dSdec20 ',1)
!
!          If  detritus = 0 : set fluxes to zero and skip algorithm
!
           IF (POC .LT. 1E-10 .OR. PON .LT. 1E-10 .OR. POP .LT. 1E-10)
     &        THEN

              DECOC = 0.0
              DECON = 0.0
              DECOP = 0.0
              DECOS = 0.0
              CNVPC = 0.0
              CNVPN = 0.0
              CNVPP = 0.0
              CNVPS = 0.0
              CNVDC = 0.0
              CNVDN = 0.0
              CNVDP = 0.0
              CNVDS = 0.0
              RC20  = 0.0
              TEMPC = 0.0
              ELFACT = 1.0
              N_FACT = 0.0
              P_FACT = 0.0
              DECOC  = 0.0
              DECOCE = 0.0

           ELSE
!
!             Calculate degrad. rate at 20oC for current stochiometry
!
              IF ((PON/POC) .GT. AUN .AND. (POP/POC) .GT. AUP) THEN
!
!                -- both stoch's above upper limit
!
                 RC20 = RC20UP

              ELSE IF ((PON/POC) .LT. ALN .OR. (POP/POC) .LT. ALP)
     &                THEN
!
!                -- one or both stoch's < lower limit
!
                 RC20 = RC20LO

              ELSE
!
!                -- both stoch's between upper and lower limit
!
                 FNUT = MIN( ((PON/POC)-ALN) / (AUN-ALN) ,
     &                       ((POP/POC)-ALP) / (AUP-ALP) )
                 RC20 = RC20LO + FNUT * (RC20UP-RC20LO)

              ENDIF
!
!             Calculate correction factors
!             for temperature
!
              IF ( IKMRK3 .EQ. 1 .AND. SWEMRS .EQ. 1 ) THEN
                 TEMP = NATTEM
              ENDIF
              TEMPC = TC**(TEMP-20)
!
!             for electron acceptor (aerobic, denitr., sulfate red.)
!
              IF ( IKMRK3 .EQ. 1 .AND. SWEMRS .EQ. 1 ) THEN
                 ELFACT = 1.0
              ELSE
                 IF (OXY .GT. 0.0) THEN
                    ELFACT = 1.0
                 ELSE IF (NO3 .GT. 0.0) THEN
                    ELFACT = B_NO3
                 ELSE
                    ELFACT = B_SULF
                 ENDIF
              ENDIF
!
!             for nutrient stripping
!
              N_FACT = 1.0 + ((PON/POC) - ANR) / ANR
              P_FACT = 1.0 + ((POP/POC) - APR) / APR
              S_FACT = 1.0 + ((POS/POC) - ASR) / ASR
              N_FACT = MAX(N_FACT,0.5)
              P_FACT = MAX(P_FACT,0.5)
              S_FACT = MAX(S_FACT,0.5)
!
!             Calculate the fluxes for mineralization and conversion
!
              DECOC = RC20 * TEMPC * ELFACT * POC
              CNVPC = B_DTPR * DECOC
              CNVDC = B_DTDR * DECOC

              DECON = RC20 * TEMPC * ELFACT * N_FACT * PON
              CNVPN = (1/N_FACT) * B_DTPR * DECON
              CNVDN = (1/N_FACT) * B_DTDR * DECON

              DECOP = RC20 * TEMPC * ELFACT * P_FACT * POP
              CNVPP = (1/P_FACT) * B_DTPR * DECOP
              CNVDP = (1/P_FACT) * B_DTDR * DECOP

              DECOS = RC20 * TEMPC * ELFACT * S_FACT * POS
              CNVPS = (1/S_FACT) * B_DTPR * DECOS
              CNVDS = (1/S_FACT) * B_DTDR * DECOS

           ENDIF

           IF ( IKMRK3 .EQ. 1 .AND. SWEMRS .EQ. 1 ) THEN

              ! emersion

              DECOCE = DECOC
              DECOC  = 0.0

           ELSE

              DECOCE = 0.0

           ENDIF

!
!          OUTPUT of subroutine
!
           PMSA(IP25) = RC20 * TEMPC * ELFACT
           PMSA(IP26) = N_FACT
           PMSA(IP27) = P_FACT
           PMSA(IP28) = DECOC
           PMSA(IP29) = DECOCE

           FL( 1 + IFLUX) = CNVPC
           FL( 2 + IFLUX) = CNVPN
           FL( 3 + IFLUX) = CNVPP
           FL( 4 + IFLUX) = CNVPS
           FL( 5 + IFLUX) = CNVDC
           FL( 6 + IFLUX) = CNVDN
           FL( 7 + IFLUX) = CNVDP
           FL( 8 + IFLUX) = CNVDS
           FL( 9 + IFLUX) = DECOC
           FL(10 + IFLUX) = DECON
           FL(11 + IFLUX) = DECOP
           FL(12 + IFLUX) = DECOS
           FL(13 + IFLUX) = DECOCE
           FL(14 + IFLUX) = DECOCE

        ENDIF
!
!       Pointers ophogen
!
        IFLUX = IFLUX + NOFLUX
        IP1   = IP1   + IN1
        IP2   = IP2   + IN2
        IP3   = IP3   + IN3
        IP4   = IP4   + IN4
        IP5   = IP5   + IN5
        IP6   = IP6   + IN6
        IP7   = IP7   + IN7
        IP8   = IP8   + IN8
        IP9   = IP9   + IN9
        IP10  = IP10  + IN10
        IP11  = IP11  + IN11
        IP12  = IP12  + IN12
        IP13  = IP13  + IN13
        IP14  = IP14  + IN14
        IP15  = IP15  + IN15
        IP16  = IP16  + IN16
        IP17  = IP17  + IN17
        IP18  = IP18  + IN18
        IP19  = IP19  + IN19
        IP20  = IP20  + IN20
        IP21  = IP21  + IN21
        IP22  = IP22  + IN22
        IP23  = IP23  + IN23
        IP24  = IP24  + IN24
        IP25  = IP25  + IN25
        IP26  = IP26  + IN26
        IP27  = IP27  + IN27
        IP28  = IP28  + IN28
        IP29  = IP29  + IN29

9000  CONTINUE

      RETURN
      END


module tgas_setup
  implicit none
  private
  public:: setup
        interface setup; module procedure setuptgas; end interface

contains
subroutine setuptgas(obsLL,odiagLL,lunin, mype, stats_tgas, nchanl, nreal, nobs, obstype,    &
                     isis, is, ltgasdiagsave, init_pass)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    setuptgas --- Compute rhs of oi for trace gas obs
!    prgrmmr:    weir             org: gmao                date: 2014-04-14
!
!   abstract:    For trace gas observations, this routine
!                  a) reads obs assigned to given mpi task (geographic region),
!                  b) simulates obs from guess,
!                  c) applies some quality control to obs,
!                  d) loads weight and innovation arrays used in minimization
!                  e) collects statistics for runtime diagnostic output
!                  f) writes additional diagnostic information to output file
!
! program history log:
!   2014-03-30   weir  - initial code
!   2014-07-24   weir  - changed to interpolation of prior and averaging
!                        kernel to model levels instead of interpolation of
!                        guess to averaging kernel levels
!   2014-11-05   weir  - fixed some bugs with the diag output
!   2014-11-14   weir  - fixed a bug with how pressure level at surface was
!                        computed for mopitt; changed how extrapolation is
!                        done at the top of the atmosphere in zintrp, this
!                        needs more work
!   2015-07-01   weir  - removed all the changes with levels, etc. above, and
!                        made everything follow ozone more closely
!
!
!   input argument list:
!     obsLL         - a linked-list of obsNode holding observations
!     odiagLL       - a linked-list of obs_diag holding obsdiags
!     lunin         - unit from which to read observations
!     mype          - mpi task id
!     nchanl        - the number of elements of the obs vector; 1 for column
!                     obs; nlays for layer obs; nlays+1 for interface obs
!     nreal         - number of pieces of non-data info (location, time, etc.)
!                     per obs
!     nobs          - number of observations
!     isis          - sensor/instrument/satellite id
!     is            - integer counter for number of obs types to process
!     obstype       - type of tgas obs
!     ltgasdiagsave - switch on diagnostic output (.false. = no output)
!     init_pass     - state of setup processing
!     stats_tgas    - sums for various statistics as a function of level
!
!   output argument list:
!     obsLL         - a linked-list of obsNode holding observations
!     odiagLL       - a linked-list of obs_diag holding obsdiags
!     stats_tgas    - sums for various statistics as a function of level
!
!$$$ end documentation block

! Declare module variables
  use mpeu_util,         only: die, perr
  use kinds,             only: r_kind, r_single, i_kind
  use constants,         only: zero, half, one, two, tiny_r_kind, huge_r_kind, &
                               cg_term, wgtlim, h300

  use m_obsdiagNode, only : obs_diag
  use m_obsdiagNode, only : obs_diags
  use m_obsdiagNode, only : obsdiagLList_nextNode
  use m_obsdiagNode, only : obsdiagNode_set
  use m_obsdiagNode, only : obsdiagNode_get
  use m_obsdiagNode, only : obsdiagNode_assert

  use m_obsNode , only : obsNode
  use m_tgasNode, only : tgasNode
  use m_tgasNode, only : tgasNode_appendto
  use m_obsLList, only : obsLList

  use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
       nc_diag_write, nc_diag_data2d
  use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close

  use obsmod, only : luse_obsdiag
  use obsmod,            only: dplat, nobskeep, mype_diaghdr, dirname,         &
                               time_offset, ianldate,                          &
                               lobsdiag_allocated, lobsdiagsave,               &
                               nlmopitt, nlacos,       &
                               nlflask

  use gsi_4dvar,         only: nobs_bins, mn_obsbin
  use gridmod,           only: get_ij, nsig
  use guess_grids,       only: nfldsig, ges_prsi, ntguessig, hrdifsig
  use gsi_bundlemod,     only: gsi_bundlegetpointer
  use gsi_chemguess_mod, only: gsi_chemguess_get, gsi_chemguess_bundle
  use tgasinfo,          only: jpch_tgas, pchanl_tgas, error_tgas, gross_tgas, &
                               nusis_tgas, iuse_tgas, b_tgas, pg_tgas,         &
                               ihave_co, ihave_co2
  use jfunc,             only: jiter, last, miter
  use m_dtime,           only: dtime_setup, dtime_check

  implicit none

! Declare passed variables
  type(obsLList ),target,dimension(:),intent(inout):: obsLL     ! a L-List array of tgasNode
  type(obs_diags),target,dimension(:),intent(inout):: odiagLL   ! a L-List array of obs_diag

  integer(i_kind),  intent(in   ) :: lunin, mype, nchanl, nreal, nobs, is
  character(20),    intent(in   ) :: isis
  character(len=*), intent(in   ) :: obstype
  logical,          intent(in   ) :: ltgasdiagsave, init_pass
  real(r_kind),     intent(inout) :: stats_tgas(9,jpch_tgas)

! Declare local parameters
  integer(i_kind),  parameter :: iint  = 1
  integer(i_kind),  parameter :: ireal = 3
  integer(i_kind),  parameter :: irmin = 6
  real(r_kind),     parameter :: r10   = 10._r_kind
  real(r_kind),     parameter :: r19   = 19._r_kind
  real(r_kind),     parameter :: tol_error = 1.e4_r_kind
  character(len=*), parameter :: myname  = 'setuptgas'
  logical,          parameter :: ldebug  = .false.
  logical,          parameter :: lcenter = .false.

! Declare local variables
  real(r_kind) :: obs, omg, rat_err2, grdtime, grdlat, grdlon, psurf
  real(r_kind) :: cg_tgas, wgross, wnotgross, wgt, arg, exp_arg, term
  real(r_kind) :: errorinv, fact

  real(r_kind), dimension(nchanl) :: obsinv, varinv3, ratio_errors
  real(r_kind), dimension(nchanl) :: pchanl, error, gross, tnoise
  real(r_kind), dimension(nchanl) :: priorobs, gesobs, uncert
  real(r_kind), dimension(nsig)   :: colmod, co2lmod
  real(r_kind), dimension(nsig+1) :: prsimod

  real(r_kind), dimension(nreal+nchanl,nobs) :: tgasdata

  real(r_single), dimension(ireal,nobs) :: diagbuf

  real(r_kind),   allocatable, dimension(:)       :: prsiobs, grdprsi
  real(r_kind),   allocatable, dimension(:)       :: priorpro, gespro
  real(r_kind),   allocatable, dimension(:,:)     :: avgker, avgwgt
  real(r_kind),   allocatable, dimension(:,:,:,:) :: ges_co, ges_co2
  real(r_single), allocatable, dimension(:,:,:)   :: rdiagbuf

  integer(i_kind) :: i, nchon, npro, nlays, jj, iextra, ibin, ifld
  integer(i_kind) :: k, l, kcut, j, jc, id, jdiag, irdim1, ier, istatus, ioff
  integer(i_kind) :: itoss, ikeep, nkeep, mm1
  integer(i_kind) :: isd, itime, iglat, iglon, idlat, idlon, iqcf, ipsurf

  integer(i_kind), dimension(iint,nobs) :: idiagbuf
  integer(i_kind), dimension(nchanl)    :: ipos, iouse

  character(12)  :: string
  character(10)  :: filex
  character(128) :: diag_tgas_file
  character(256) :: ctype

  logical :: l_may_be_passive, lproceed, in_curbin, in_anybin, lqcflag
  logical :: lacos, lmopitt, lflask

  logical, dimension(nobs) :: luse
  integer(i_kind),dimension(nobs):: ioid  ! initial (pre-distribution) observation ID

  type(tgasNode ), pointer:: my_head
  type(obs_diag ), pointer:: my_diag
  type(obs_diags), pointer:: my_diagLL
  type(obsLList ), pointer, dimension(:):: tgashead
  tgashead => obsLL(:)

! Shortcut to not have to redo test many times
  lacos   = (trim(obstype) == 'acos')
  lmopitt = (trim(obstype) == 'mopitt')
  lflask  = (trim(obstype) == 'flask')

! Initialize observation dependent variables
  if (lacos) then
     npro  = nlacos
     nlays = nlacos - 1

     if (nchanl /= 1) then
        write(6,*) trim(myname), ': ***ERROR*** in channel number'
        write(6,*) trim(myname), ': nchanl = ', nchanl
        write(6,*) trim(myname), ' ***STOP***'
        call stop2(70)
     end if

  else if (lmopitt) then
     npro  = nlmopitt
     nlays = nlmopitt

     if (nchanl /= npro) then
        write(6,*) trim(myname), ': ***ERROR*** in channel number'
        write(6,*) trim(myname), ': nchanl = ', nchanl
        write(6,*) trim(myname), ' ***STOP***'
        call stop2(69)
     end if

  else if (lflask) then
     nlays = 0
     npro  = nlflask

!    if (nchanl /= npro) then
     if (nchanl /= 2) then
        write(6,*) trim(myname), ': ***ERROR*** in channel number'
        write(6,*) trim(myname), ': nchanl = ', nchanl
        write(6,*) trim(myname), ' ***STOP***'
        call stop2(69)
     end if

! Return if unsupported obstype
  else
     return

  end if

! Allocate local variables
  allocate(prsiobs(nlays+1), grdprsi(nlays+1))
  allocate(priorpro(npro), gespro(npro))
  allocate(avgker(nchanl,npro), avgwgt(npro,nsig))

! If required guess fields are unavaiable, simply return
  call check_vars_(lproceed)
  if (.not. lproceed) return

! If required guess fields are available, extract from bundle
  call init_vars_

  mm1 = mype + 1

! Initialize arrays
  do k = 1,nchanl
     ipos(k)   = 0
     pchanl(k) = zero
     gross(k)  = huge_r_kind
     tnoise(k) = huge_r_kind
     iouse(k)  = -2
  end do

! Locate data for satellite in tgasinfo arrays, and remove channels if
! necessary
  itoss = 1
  l_may_be_passive = .false.
  jc = 0
  if (ldebug) print *, 'jpch_tgas = ', jpch_tgas, 'nchanl = ', nchanl
  do j = 1,jpch_tgas
     if (ldebug) print *, 'isis = ', isis, 'nusis_tgas(j) = ', nusis_tgas(j)
     if (isis == nusis_tgas(j)) then
        jc = jc + 1
        if (nchanl < jc) then
           write(6,*) trim(myname), ': ***ERROR*** in channel number'
           write(6,*) trim(myname), ': jc    = ', jc, ', nchanl = ', nchanl
           write(6,*) trim(myname), ' ***STOP***'
           call stop2(71)
        end if

        ipos(jc)   = j
        pchanl(jc) = pchanl_tgas(j)
        gross(jc)  = min(r10*gross_tgas(j), h300)
        tnoise(jc) = error_tgas(j)
        iouse(jc)  = iuse_tgas(j)

        if (-1 < iouse(jc)) l_may_be_passive = .true.
        if (tnoise(jc) < tol_error) itoss = 0

        if (ldebug) then
           print *, 'pchanl = ', pchanl(jc)
           print *, 'gross  = ', gross(jc)
           print *, 'tnoise = ', tnoise(jc)
           print *, 'iouse  = ', iouse(jc)
           print *, 'ltgasdiagsave = ', ltgasdiagsave
        end if
     end if
  end do
  nchon = jc

! Handle error conditions
  if (nchon < nchanl) then
!    Unsure how to properly implement this, so reporting as an error
!    Instead, turn off channels with the iuse flag
!    if (mype == 0) write(6,*) trim(myname), ': level number reduced for ',    &
!                              obstype, ' ', nchanl,' --> ', nchon
     write(6,*) trim(myname), ': ***ERROR*** in channel number'
     write(6,*) trim(myname), ': nchon = ', nchon, ', nchanl = ', nchanl
     write(6,*) trim(myname), ' ***STOP***'
     call stop2(72)
  end if
  if (nchon == 0) then
     if (mype == 0) write(6,*) trim(myname), ': no channels found for ', isis
     if (nobs >  0) read(lunin)
     goto 135
  end if
  if (itoss == 1) then
     if (mype == 0) write(6,*) trim(myname), ': all obs variances > 1.e4, ' // &
                               'do not use data from satellite ', isis
     if (nobs >  0) read(lunin)
     goto 135
  end if

! Initialize variables used in processing
  nkeep = 0
  do i = 1,nobs
     ikeep = 0
     do k = 1,nchanl
        if (0 < iouse(k) .or. ltgasdiagsave) ikeep = 1
     end do
     nkeep = nkeep + ikeep
  end do

! If none of the data will be assimilated and don't need diagnostics, return to
! calling program
  if (nkeep == 0) then
     call final_vars_
     return
  end if

! If requested, save data for diagnostic ouput
  if (ltgasdiagsave) then
     id     = 0
     irdim1 = irmin
     if (lobsdiagsave) irdim1 = irdim1 + 4*miter + 1
     allocate(rdiagbuf(irdim1,nchanl,nobs))
  end if

! Read and transform data
  read(lunin) tgasdata, luse, ioid

! Index information for data array (see read_tgas subroutine)
  isd    = 1   ! index of satellite (unused in ozone routines, fixme)
  itime  = 2   ! index of analysis relative obs time
  iglon  = 3   ! index of grid relative obs location (x)
  iglat  = 4   ! index of grid relative obs location (y)
  idlon  = 5   ! index of earth relative longitude (degrees)
  idlat  = 6   ! index of earth relative latitude (degrees)
  iqcf   = 7   ! index of obs quality control flag
  ipsurf = 8   ! index of surface pressure

  if (ldebug) then
     print *, 'ntguessig = ', ntguessig, 'nfldsig = ', nfldsig
     print *, 'hrdifsig  = '
     print *, hrdifsig
  end if

  call dtime_setup
  do i = 1,nobs
     grdtime = tgasdata(itime,i)
     grdlat  = tgasdata(iglat,i)
     grdlon  = tgasdata(iglon,i)
     lqcflag = (abs(tgasdata(iqcf,i) - one) < 1.e-6_r_kind)                    ! Paranoid casting to logical
     psurf   = tgasdata(ipsurf,i)

!    If debugging, allow centering of obs in space and time to eliminate
!    interpolation
     if (ldebug .and. lcenter) then
       if (mype == 0) write(6,*) trim(myname), ': *** WARNING: centering ',    &
                                 'obs in time and moving to nearest grid ',    &
                                 'point ***'
        grdtime = 3._r_kind
        grdlat  = real(int(grdlat))
        grdlon  = real(int(grdlon))
     end if

     call dtime_check(grdtime, in_curbin, in_anybin)
     if (.not. in_anybin) cycle

if (in_curbin) then
     if (nobskeep > 0) then
        write(6,*) trim(myname), ': nobskeep ', nobskeep
        call stop2(259)
     end if

!    Interpolate guess interface pressure (ges_prsi) to obs time and
!    location (prsimod)
     call tintrp2a1(ges_prsi, prsimod, grdlat, grdlon, grdtime, hrdifsig,      &
                    nsig+1, mype, nfldsig)

!    Read and construct obs variables:
!       1. priorobs = prior for observed variable
!       2. avgker   = averaging kernel (times pres. wght. fcn. for column obs)
!       3. gespro   = guess/model profile
!       4. priorpro = prior for   profile
!       5. uncert   = standard deviation of obs error
!    For observations of multiple species, the "profile" can contain
!    observations of each of those species; see flask obstype.  This
!    functionality is still being developed.
     if (lacos) then
        prsiobs(1) = psurf*1.e-4_r_kind
        do k = 1,nlays
           prsiobs(k+1) = psurf - real(nlays-k, r_kind)/r19*psurf
        end do
        pchanl = psurf

!       Map obs pressure (prsiobs) to grid relative vertical coordinate (grdprsi)
        grdprsi = prsiobs/r10
        do k = 1,nlays+1
           if (prsimod(1) < grdprsi(k)) grdprsi(k) = prsimod(1)
           call grdcrd1(grdprsi(k), prsimod, nsig+1, -1)
        end do

!       Interpolate guess values to obs time and location, then average over
!       obs layers
        call tintrp2a1(ges_co2, co2lmod, grdlat, grdlon, grdtime, hrdifsig,    &
                       nsig, mype, nfldsig)
        call zavgtgas_(co2lmod, .false., gespro, avgwgt)

!       Read a priori values, averaging kernel, and uncertainty
        do k = 1,npro
           priorpro(k) = tgasdata(k+8,i)
        end do
        do k = 1,npro
           avgker(1,k) = tgasdata(k+8+npro,i)
        end do

        priorobs(1) = tgasdata(1+8+2*npro,i)
        uncert(1)   = tgasdata(2+8+2*npro,i)

     else if (lmopitt) then
        prsiobs(1) = psurf
        do k = 2,nlays
           prsiobs(k) = 1000._r_kind - real(k-1, r_kind)*100._r_kind
           prsiobs(k) = min(prsiobs(k), psurf)
        end do
!       Not sure if this is the best choice (fixme)
        prsiobs(nlays+1) = 26._r_kind
        pchanl = prsiobs(1:nlays)

!       Map obs pressure (prsiobs) to grid relative vertical coordinate (grdprsi)
        grdprsi = prsiobs/r10
        do k = 1,nlays+1
           if (prsimod(1) < grdprsi(k)) grdprsi(k) = prsimod(1)
           call grdcrd1(grdprsi(k), prsimod, nsig+1, -1)
        end do

!       Interpolate guess values to obs time and location, then average over
!       obs layers
        call tintrp2a1(ges_co, colmod, grdlat, grdlon, grdtime, hrdifsig,      &
                       nsig, mype, nfldsig)
        call zavgtgas_(colmod, .true., gespro, avgwgt)

!       Read a priori values, averaging kernel, and uncertainty
        do k = 1,npro
           priorpro(k) = tgasdata(k+8,i)
        end do
        do k = 1,npro
           do j = 1,npro
              avgker(j,k) = tgasdata(k+(j-1)*npro+8+npro,i)
           end do
        end do

        do k = 1,npro
!          uncert(k) = sqrt(tgasdata(k+8+npro+npro**2,i))
!          For now, just use ones because product has errors (fixme)
           uncert(k) = one
        end do

!       Prevent nans when we take the log
        do kcut = 1,npro
           if (tiny_r_kind < priorpro(kcut)) exit
        end do
        priorpro(1:kcut-1) = log10(priorpro(kcut))
        do k = kcut,npro
           priorpro(k) = log10(priorpro(k))
        end do

        priorobs = priorpro

     else if (lflask) then
!       This will need to be read/computed from data (fixme)
        psurf      = 1000._r_kind
        prsiobs(1) = psurf
        pchanl     = psurf

!       Map obs pressure (prsiobs) to grid relative vertical coordinate (grdprsi)
        grdprsi = prsiobs/r10
        do k = 1,nlays+1
           if (prsimod(1) < grdprsi(k)) grdprsi(k) = prsimod(1)
           call grdcrd1(grdprsi(k), prsimod, nsig+1, -1)
        end do

!       Interpolate guess values to obs time and location (called gespro)
        call tintrp31(ges_co,  gespro(1), grdlat, grdlon, grdprsi(1), grdtime, &
                      hrdifsig, mype, nfldsig)
        call tintrp31(ges_co2, gespro(2), grdlat, grdlon, grdprsi(1), grdtime, &
                      hrdifsig, mype, nfldsig)

        priorpro = (/ zero, zero /)
!       uncert   = (/ tgasdata(1+8,i), tgasdata(2+8,i) /)
!       For now, just use ones because still testing (fixme)
        uncert   = (/ one, one /)

        avgker   = reshape((/ one, zero, zero, one /), (/ 2, 2 /))
        priorobs = priorpro

     end if

!    Create guess corresponding to obs
     gesobs = priorobs + matmul(avgker, (gespro - priorpro))

     if (ldebug) then
        print *, 'grdlat     = ', grdlat, 'grdlon     = ', grdlon
        print *, 'grdtime    = ', grdtime
        print *, 'qcflag     = ', lqcflag
        print *, 'psurf      = ', psurf
        print *, 'prsimod*10 = '
        print *, prsimod*r10
        print *, 'prsiobs    = '
        print *, prsiobs
        print *, 'grdprsi    = '
        print *, grdprsi
        print *, 'avgker     = '
        print *, avgker
        print *, 'priorpro   = '
        print *, priorpro
        print *, 'gespro     = '
        print *, gespro
        print *, 'uncert     = '
        print *, uncert
        print *, 'priorobs   = '
        print *, priorobs
     end if

     if (ltgasdiagsave .and. luse(i)) then
        id = id + 1
        idiagbuf(1,id) = mype                            ! mpi task number
        diagbuf(1,id)  = tgasdata(idlat,i)               ! lat (degree)
        diagbuf(2,id)  = tgasdata(idlon,i)               ! lon (degree)
        diagbuf(3,id)  = tgasdata(itime,i) - time_offset ! time (hours rel. to ana.)
     end if

!    Calculate innovations, perform gross checks, and accumualte statistics
     do k = 1,nchanl
        j    = ipos(k)
        ioff = nreal + k

        obs = tgasdata(ioff,i)

!       Apply log transform to co data
        if (lmopitt) then
           if (obs < tiny_r_kind) then
              obs = gesobs(k)
           else
              obs = log10(obs)
           end if

        else if (lflask .and. k == 1) then
           if (obs < tiny_r_kind) then
              obs = gesobs(k)
           else
              obs = log10(obs)
           end if

        end if

!       Compute innovation and load obs error into local array
        obsinv(k) = obs - gesobs(k)
        error(k)  = tnoise(k) * uncert(k)

        if (ldebug) print *, 'gesobs    = ', gesobs(k), 'obs       = ', obs

!       Set inverse obs error squared and ratio_errors
        if (error(k) < tol_error) then
           varinv3(k)      = one/(error(k)**2)
           ratio_errors(k) = one
        else
           varinv3(k)      = zero
           ratio_errors(k) = zero
        end if

!       Toss the obs not recommended by the data provider, and perform gross
!       check
        if (lqcflag .or. gross(k) < abs(obsinv(k))) then
           varinv3(k)      = zero
           ratio_errors(k) = zero
           if (luse(i)) stats_tgas(2,j) = stats_tgas(2,j) + one                ! # obs tossed
        end if

!       Accumulate numbers for statistics
        rat_err2 = ratio_errors(k)**2

        if (luse(i)) then
           if (     (iouse(k) == -1 .and. ltgasdiagsave)                       &
               .or. (tiny_r_kind < varinv3(k))         ) then
              omg = obsinv(k)

              if (ldebug) print *, trim(myname), ': o-g = ', omg

              stats_tgas(1,j) = stats_tgas(1,j) + one                          ! # obs
              stats_tgas(3,j) = stats_tgas(3,j) + omg                          ! (o-g)
              stats_tgas(4,j) = stats_tgas(4,j) + omg*omg                      ! (o-g)**2
              stats_tgas(5,j) = stats_tgas(5,j) + omg*omg*varinv3(k)*rat_err2  ! penalty
              stats_tgas(6,j) = stats_tgas(6,j) + obs                          ! obs

              exp_arg  = -half*varinv3(k)*omg**2
              errorinv = sqrt(varinv3(k))
              if (tiny_r_kind < pg_tgas(j) .and. tiny_r_kind < errorinv) then
                 arg       = exp(exp_arg)
                 wnotgross = one - pg_tgas(j)
                 cg_tgas   = b_tgas(j)*errorinv
                 wgross    = cg_term*pg_tgas(j)/(cg_tgas*wnotgross)
                 term      = log((arg + wgross)/(one + wgross))
                 wgt       = one - wgross/(arg + wgross)
              else
                 term      = exp_arg
                 wgt       = one
              end if

              stats_tgas(8,j) = stats_tgas(8,j) - two*rat_err2*term
              if (wgt < wgtlim) stats_tgas(9,j) = stats_tgas(9,j) + one
           end if

!          Optionally save data for diagnostics
!          (Currently only using first 5 components, but keeping the first
!          dimension of rdiagbuf at 6 to preserve compatibility with ozone
!          diagnostics)
           if (ltgasdiagsave) then
              rdiagbuf(1,k,id) = obs                    ! obs
              rdiagbuf(2,k,id) = obsinv(k)              ! obs-ges
              rdiagbuf(3,k,id) = varinv3(k)*rat_err2    ! inverse (obs error)**2
              rdiagbuf(4,k,id) = pchanl(k)              ! obs pressure
              rdiagbuf(5,k,id) = prsimod(1)*r10         ! mod surface pressure
              rdiagbuf(6,k,id) = zero                   !
           end if

           if (tiny_r_kind < rat_err2*varinv3(k)) then
              stats_tgas(7,j) = stats_tgas(7,j) + one
           end if
        end if

!       If not assimilating this observation, reset inverse variance to zero
        if (iouse(k) < 1) then
           varinv3(k) = zero
           ratio_errors(k) = zero
           rat_err2 = zero
        end if
     end do

!    Check all information for obs.  If there is at least one piece of
!    information that passed quality control, use this observation.
     ikeep = 0
     do k = 1,nchanl
        if (ldebug) then
           print *, 'ratio_errors = ', ratio_errors(k)
           print *, 'varinv3      = ', varinv3(k)
           print *, 'ratio_errors**2*varinv3 = ',                              &
                    ratio_errors(k)**2*varinv3(k)
        end if
        if (tiny_r_kind < (ratio_errors(k)**2)*varinv3(k)) ikeep = 1
     end do
end if ! (in_curbin)

     if (ldebug) print *, 'ikeep = ', ikeep

!    In principle, we want ALL obs in the diagnostics structure, but for
!    passive obs (monitoring), it is difficult to do if ltgasdiagsave
!    is not on in the first outer loop. For now we use l_may_be_passive
     if (ldebug) print *, 'l_may_be_passive = ', l_may_be_passive
     if (l_may_be_passive) then
!       Link observation to appropriate observation bin
        if (nobs_bins > 1) then
           ibin = nint(grdtime*60/mn_obsbin) + 1
        else
           ibin = 1
        end if
        if (ibin < 1 .or. nobs_bins < ibin) then
           write(6,*) mype, ' error nobs_bins, ibin = ', nobs_bins, ibin
        end if

        if(luse_obsdiag) my_diagLL => odiagLL(ibin)

if (in_curbin) then
!       Process obs that have at least one piece of information that passed qc
!       checks
        if (.not. last .and. ikeep == 1) then
           allocate(my_head)
           call tgasNode_appendto(my_head,tgashead(ibin))

           my_head%idv = is
           my_head%iob = ioid(i)
           my_head%elat= grdlat
           my_head%elon= grdlon

           my_head%luse    = luse(i)
           my_head%time    = grdtime
           my_head%nchanl  = nchanl
           my_head%npro    = npro
           my_head%obstype = obstype

           allocate(my_head%res(nchanl),         &
                    my_head%diags(nchanl),       &
                    my_head%err2(nchanl),        &
                    my_head%raterr2(nchanl),     &
                    my_head%ipos(nchanl),        &
                    my_head%avgker(nchanl,npro), &
                    my_head%avgwgt(npro,nsig),   &
                    stat=istatus)

           if (istatus /= 0) then
              write(6,*) trim(myname), ': allocation error for tgas ' //       &
                         'pointer, istatus = ', istatus
           end if

!          Set (i,j) indices of guess gridpoint that bound obs location
           call get_ij(mm1, grdlat, grdlon, my_head%ij, my_head%wij)

           if (ldebug) then
              print *, 'ij  = ', my_head%ij
              print *, 'wij = ', my_head%wij
           end if

           my_head%ipos(:)      = ipos(1:nchanl)
           my_head%res(:)       = obsinv(1:nchanl)
           my_head%err2(:)      = varinv3(1:nchanl)
           my_head%raterr2(:)   = ratio_errors(1:nchanl)**2

           do k = 1,npro
              do j = 1,nchanl
                 my_head%avgker(j,k) = avgker(j,k)
              end do
           end do

           do l = 1,nsig
              do k = 1,npro
                 my_head%avgwgt(k,l) = avgwgt(k,l)
              end do
           end do

           my_head => null()
        end if ! (.not. last .and. ikeep == 1)
end if ! (in_curbin)

!       Link obs to diagnostics structure
        do k = 1,nchanl
           if (luse_obsdiag) then
              my_diag => obsdiagLList_nextNode(my_diagLL,&
                 create = .not. lobsdiag_allocated      ,&
                    idv = is            ,&
                    iob = ioid(i)       ,&
                    ich = k             ,&
                   elat = grdlat        ,&
                   elon = grdlon        ,&
                   luse = luse(i)       ,&
                  miter = miter         )
           end if

           if(.not.associated(my_diag)) call die(myname,&
             "obsdiagLList_nextnode(), create =",.not.lobsdiag_allocated)

if (in_curbin) then
           if(luse_obsdiag) then
             call obsdiagNode_set(my_diag               ,&
               wgtjo   = varinv3(k)*ratio_errors(k)**2  ,&
               jiter   = jiter                          ,&
               muse    = (ikeep==1)                     ,&
               nldepart= obsinv(k)                      )
           endif

           if (.not. last .and. ikeep == 1) then
              my_head => tailNode_typecast_(tgashead(ibin))
                 if(.not.associated(my_head)) call die(myname,&
                    "unexpected, associated(my_head) =",associated(my_head))

              if(luse_obsdiag) then
                 call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,k,myname,"my_diag:my_head")
                 my_head%diags(k)%ptr => my_diag
              endif
              my_head => null()

           end if

           if (ltgasdiagsave .and. lobsdiagsave .and. luse(i)) then
            associate( odiag => my_diag )
              jdiag = irmin
              do jj = 1,miter
                 jdiag = jdiag + 1
                 if (odiag%muse(jj)) then
                    rdiagbuf(jdiag,k,id) =  one
                 else
                    rdiagbuf(jdiag,k,id) = -one
                 end if
              end do
              do jj = 1,miter+1
                 jdiag = jdiag + 1
                 rdiagbuf(jdiag,k,id) = odiag%nldepart(jj)
              end do
              do jj = 1,miter
                 jdiag = jdiag + 1
                 rdiagbuf(jdiag,k,id) = odiag%tldepart(jj)
              end do
              do jj = 1,miter
                 jdiag = jdiag + 1
                 rdiagbuf(jdiag,k,id) = odiag%obssen(jj)
              end do
            end associate ! odiag
           end if
end if ! (in_curbin)
        end do ! (k = 1,nchanl)

     else ! (.not. lmaybepassive)
if (in_curbin) then
        if (ltgasdiagsave .and. lobsdiagsave .and. luse(i)) then
           rdiagbuf(irmin+1:irdim1,1:nchanl,id) = zero
        end if
end if ! (in_curbin)

     end if ! (l_may_be_passive)
  end do ! (i = 1,nobs)

! If requested, write to diagnostic file
  if (ltgasdiagsave .and. 0 < id) then
     filex = obstype
     write(string,100) jiter
100  format('_',i2.2)
     diag_tgas_file =  trim(dirname) // trim(filex) // '_' // trim(dplat(is))  &
                    // string
     if (init_pass) then
       open(4, file=diag_tgas_file, form='unformatted', status='unknown',      &
            position='rewind')
     else
       open(4, file=diag_tgas_file, form='unformatted', status='old',          &
            position='append')
     end if
     iextra = npro
     if (init_pass .and. mype == mype_diaghdr(is)) then
        write(6,*) trim(myname), ': write header record for ', isis, iint,     &
                   ireal, iextra,' to file ', trim(diag_tgas_file), ' ',       &
                   ianldate
        write(4) isis, dplat(is), obstype, jiter, nchanl, ianldate, iint,      &
                 ireal, iextra
        write(4) real(pchanl,r_single), real(gross,r_single),                  &
                 real(tnoise,r_single), iouse
     end if
     write(4) id
     write(4) idiagbuf(:,1:id), diagbuf(:,1:id), rdiagbuf(:,:,1:id)
     close(4)
  end if

! Jump to this line if problem with data
135 continue

! Clean up
  deallocate(prsiobs, grdprsi, priorpro, gespro, avgker, avgwgt)

  if (ltgasdiagsave)      deallocate(rdiagbuf)
  call final_vars_

! End of routine
  return

  contains
  function tailNode_typecast_(oll) result(ptr_)
!>  Cast the tailNode of oll to an obsNode, as in
!>      ptr_ => typecast_(tailNode_(oll))

    use m_tgasNode, only: tgasNode, typecast_ => tgasNode_typecast
    use m_obsLList, only: obsLList , tailNode_ => obsLList_tailNode
    use m_obsNode , only: obsNode
    implicit none
    type(tgasNode),pointer:: ptr_
    type(obsLList ),target ,intent(in):: oll

    class(obsNode),pointer:: inode_
    inode_ => tailNode_(oll)
    ptr_   => typecast_(inode_)
  end function tailNode_typecast_

  subroutine check_vars_(lproceed)
     logical, intent(out) :: lproceed
     integer(i_kind) :: ivar, istatus

     lproceed = .true.

!    Check to see if required guess fields are available
     if (ihave_co) then
        call gsi_chemguess_get('var::co', ivar, istatus)
        lproceed = lproceed .and. (ivar > 0)
     end if
     if (ihave_co2) then
        call gsi_chemguess_get('var::co2', ivar, istatus)
        lproceed = lproceed .and. (ivar > 0)
     end if
  end subroutine check_vars_

  subroutine init_vars_
     real(r_kind), dimension(:,:,:), pointer :: rank3 => NULL()

     integer(i_kind)  :: ifld, ier
     character(len=5) :: varname

!    If require guess vars available, extract from bundle
     if (size(gsi_chemguess_bundle) == nfldsig) then
!       Get carbon monoxide
        if (ihave_co) then
           varname = 'co'
           call gsi_bundlegetpointer(gsi_chemguess_bundle(1), trim(varname),   &
                                     rank3, ier)
           if (ier == 0) then
              if (allocated(ges_co)) then
                 write(6,*) trim(myname), ': ges_co already incorrectly ' //   &
                            'allocated'
                 call stop2(997)
              end if
              allocate(ges_co(size(rank3,1),size(rank3,2),size(rank3,3),       &
                              nfldsig))
              ges_co(:,:,:,1) = rank3
              do ifld = 2,nfldsig
                 call gsi_bundlegetpointer(gsi_chemguess_bundle(ifld),         &
                                           trim(varname), rank3, ier)
                 ges_co(:,:,:,ifld) = rank3
              end do
           else
              write(6,*) trim(myname), ': ', trim(varname), ' not found ' //   &
                         'in chem bundle, ier = ', ier
              call stop2(998)
           end if
        end if

!       Get carbon dioxide
        if (ihave_co2) then
           varname = 'co2'
           call gsi_bundlegetpointer(gsi_chemguess_bundle(1), trim(varname),   &
                                     rank3, ier)
           if (ier == 0) then
              if (allocated(ges_co2)) then
                 write(6,*) trim(myname), ': ges_co2 already incorrectly ' //  &
                            'allocated'
                 call stop2(997)
              end if
              allocate(ges_co2(size(rank3,1),size(rank3,2),size(rank3,3),      &
                               nfldsig))
              ges_co2(:,:,:,1) = rank3
              do ifld = 2,nfldsig
                 call gsi_bundlegetpointer(gsi_chemguess_bundle(ifld),         &
                                           trim(varname), rank3, ier)
                 ges_co2(:,:,:,ifld) = rank3
              end do
           else
              write(6,*) trim(myname), ': ', trim(varname), ' not found ' //   &
                         'in chem bundle, ier = ', ier
              call stop2(998)
           end if
        end if
     else
        write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig, ' //   &
                   'size(gsi_chemguess_bundle) = ', nfldsig,                   &
                   size(gsi_chemguess_bundle)
        call stop2(999)
     end if
  end subroutine init_vars_

  subroutine final_vars_
     if (allocated(ges_co))   deallocate(ges_co)
     if (allocated(ges_co2))  deallocate(ges_co2)
  end subroutine final_vars_

  subroutine zavgtgas_(f, llaypro, g, w)
     real(r_kind), intent(in   ) :: f(nsig)
     logical,      intent(in   ) :: llaypro
     real(r_kind), intent(  out) :: g(npro), w(npro,nsig)

     real(r_kind)    :: avg(nlays), wgt(nlays,nsig)

     real(r_kind)    :: dz1, dz2, delp, delz, dlay
     integer(i_kind) :: iz1, iz2
     logical         :: lincrease

     avg = zero
     wgt = zero

     do j = 1,nlays
        if (grdprsi(1) < grdprsi(nlays+1)) then
          dz1 = grdprsi(j+1)
          dz2 = grdprsi(j)
        else
          dz1 = grdprsi(j)
          dz2 = grdprsi(j+1)
        end if

        iz1 = dz1
        iz2 = dz2
        if (nsig < iz1) iz1 = nsig

!       Avoid division by zero, filled by extrapolation below
!       Think this needs some work, can create zeros if two obs levels
!       are within one model level (fixme)
        if (iz1 == iz2) cycle

        dlay = zero
        do l = iz1,iz2,-1
           delz = one
           if (l == iz1) delz =         dz1 - iz1
           if (l == iz2) delz = delz - (dz2 - iz2)

           delp = prsimod(l) - prsimod(l+1)

           dlay     = dlay   +      delp*delz
           avg(j)   = avg(j) + f(l)*delp*delz
           wgt(j,l) =               delp*delz
        end do

        avg(j) = avg(j)/dlay

        do l = 1,nsig
           wgt(j,l) = wgt(j,l)/dlay
        end do

        if (ldebug) then
           print *, 'iz1  = ', iz1,  'iz2  = ', iz2
           print *, 'dlay = ', dlay, 'avg  = ', avg(j)
        end if
     end do

!    Extrapolate to any obs layers entirely ABOVE model layers
     do k = 1,nlays
        if (avg(k) /= zero) exit
     end do
     do j = 1,k-1
        avg(j)   = avg(k)
        wgt(j,:) = wgt(k,:)
     end do
     if (ldebug) print *, trim(myname), ': extrapolating to top ', k-1,        &
                          ' layers ...'

!    Extrapolate to any obs layers entirely BELOW model layers
     do k = nlays,1,-1
        if (avg(k) /= zero) exit
     end do
     do j = k+1,nlays
        avg(j)   = avg(k)
        wgt(j,:) = wgt(k,:)
     end do
     if (ldebug) print *, trim(myname), ': extrapolating to bottom ',          &
                          nlays-(k+1), ' layers ...'

!    Is it a layer profile or not (interface profile)?
     if (llaypro) then
!       Copy layer data to outputs
        g = avg
        w = wgt
     else
!       Interpolate layer data to interface data
        g(1) = avg(1)
        do k = 2,nlays
           g(k) = 0.5*(avg(k-1) + avg(k))
        end do
        g(nlays+1) = avg(nlays)

        do l = 1,nsig
           w(1,l) = wgt(1,l)
           do k = 2,nlays
              w(k,l) = 0.5*(wgt(k-1,l) + wgt(k,l))
           end do
           w(nlays+1,l) = wgt(nlays,l)
        end do
     end if

  end subroutine zavgtgas_

end subroutine setuptgas
end module tgas_setup