MODULE letkf_local
  !===============================================================================
  ! MODULE: letkf_local
  !
  ! USES:
  !   use common
  !   use common_mpi
  !   use common_mom4
  !   use common_mpi_mom4
  !   use common_letkf
  !   use letkf_obs
  !   use params_letkf
  !
  ! PUBLIC TYPES:
  !                 implicit none
  !                 [save]
  !
  !                 <type declaration>
  !
  ! PUBLIC MEMBER FUNCTIONS:
  !           <function>                     ! Description
  !
  ! PUBLIC DATA MEMBERS:
  !           <type> :: <variable>           ! Variable description

  ! DESCRIPTION:
  !   This module contains the subroutines necessary to perform localization.
  !   It is an offshoot of letkf_tools, which previously contained
  !   all localization routines. The localization algorithm has been significantly
  !   updated versus Miyoshi's original approach, and special modifications
  !   have been made specific to the ocean domain.
  !
  !   The longer-term purpose of isolating these routines in
  !   an independent module is to allow for further development of localization
  !   approaches, in particular those utilizing computational geometry tools
  !   such as:
  !   kd-tree, kNN search and range search
  !   Graph representation and A* search
  !
  ! !REVISION HISTORY:
  !   04/03/2014 Steve Penny created for use with OCEAN at NCEP.
  !
  ! Designed by Prof. Stephen G. Penny
  ! University of Maryland, College Park
  !
  !-------------------------------------------------------------------------------
  ! $Author$
  !===============================================================================

  USE common
  USE common_mpi
  USE common_mom4
  USE common_mpi_mom4
  USE common_letkf
  USE letkf_obs !contains debug_hdxf_0, and nobsgrd
  USE params_letkf, ONLY: nbv, DO_NO_VERT_LOC, localization_method

  REAL(r_size),PARAMETER :: var_local(nv3d+nv2d,nid_obs) = 1.0d0

  !  REAL(r_size),PARAMETER :: var_local(nv3d+nv2d,nid_obs) = RESHAPE( &      !(OCEAN) !(DO_SFCFLUXES)
  !!           U      V      T      S    SSH    SST    SSS     uflx   vflx  tflux  qflux    u10    v10    t2m    q2m PRESmsl prate    dlw    dsw  longwv shrtwv
  !   & (/ 1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & ! U !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & ! V !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! T !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! S !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! SSH !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! SST !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0 /) & ! SSS !(OCEAN)
  !  & ,(/nv3d+nv2d,nid_obs/))
  ! STEVE: note: this was a sort of 'trick' to make sure that the SFC variables
  ! were analyzed separately. All that was needed for this to occur was to have
  ! the var_local vector associated with each SFC variable to be different than
  ! the vector associated with the ocean interior variables. !(DO_SFCFLUXES)
  ! As a result, I can compute adaptive inflation separately for the SFC (and
  ! apply none to the ocean interior).

  !  REAL(r_size),PARAMETER :: var_local(nv3d+nv2d,nid_obs) = RESHAPE( &      !(OCEAN)
  !!           U      V      T      S    SSH    SST    SSS     uflx   vflx  tflux  qflux    u10    v10    t2m    q2m PRESmsl prate    dlw    dsw  longwv shrtwv
  !   & (/ 1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & ! U !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & ! V !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  0.0d0, 0.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! T !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  0.0d0, 0.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & ! S !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! SSH !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  0.0d0, 0.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! SST !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  0.0d0, 0.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0 /) & ! SSS !(OCEAN)
  !  & ,(/nv3d+nv2d,nid_obs/))
  !!  &
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! uflx !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! vflx !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! tflux !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! qflux !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! u10 !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! v10 !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! t2m !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! q2m !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! PRESmsl !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! prate !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! dlw !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! dsw !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, & ! longwv !(OCEAN)
  !  &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0 /)& ! shrtwv !(OCEAN)
  !  & ,(/nv3d+nv2d,nid_obs/))
  !NOTE: the obs are the rows and the model variables the columns

  !  REAL(r_size),PARAMETER :: var_local(nv3d+nv2d,nid_obs) = RESHAPE( &      !(OCEAN)
  !!           U      V      T      S    SSH    SST    SSS                      !(OCEAN)
  !   & (/ 1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  & ! U             !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  & ! V             !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  & ! T             !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  & ! S             !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  & ! SSH           !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0,  & ! SST           !(OCEAN)
  !   &    1.0d0, 1.0d0, 1.0d0, 1.00d0, 1.0d0, 1.0d0, 1.0d0 /)& ! SSS           !(OCEAN)
  !   & ,(/nv3d+nv2d,nid_obs/))
  !NOTE: the obs are the rows and the model variables the columns
  INTEGER,SAVE :: var_local_n2n(nv3d+nv2d)

CONTAINS

  SUBROUTINE obs_local(ij,ilev,var_local,hdxf,rdiag,rloc,dep,nobsl,nobstotal)
    !===============================================================================
    ! Project global observations to local
    !     (hdxf_global,dep_global,rdiag_global) -> (hdxf,dep,rdiag)
    !===============================================================================
    IMPLICIT NONE
    INTEGER,INTENT(IN) :: ij,ilev,nobstotal
    REAL(r_size),INTENT(IN) :: var_local(nid_obs)
    REAL(r_size),INTENT(OUT) :: hdxf(nobstotal,nbv)
    REAL(r_size),INTENT(OUT) :: rdiag(nobstotal)
    REAL(r_size),INTENT(OUT) :: rloc(nobstotal)
    REAL(r_size),INTENT(OUT) :: dep(nobstotal)
    INTEGER,INTENT(OUT) :: nobsl
    REAL(r_size) :: minlon,maxlon,minlat,maxlat,dist,dlev
    REAL(r_size) :: tmplon,tmplat,tmperr,tmpwgt(nlev)
    INTEGER :: tmpqc
    INTEGER,ALLOCATABLE:: nobs_use(:)
    INTEGER :: imin,imax,jmin,jmax,im,ichan
    INTEGER :: n,nn,tvnn,iobs
    !STEVE: for (OCEAN):
    LOGICAL :: blocked_by_land     !Use these three lines to identify gulf vs. pacific points in localization
    REAL(r_size) :: xlat,xlon,lxpa
    REAL(r_size) :: olat,olon,olev,oelm,lopa
    REAL(r_size) :: f1lon,f1lat,f2lon,f2lat
    REAL(r_size) :: dist1,dist2,a,b,u,v,lu,lv
    REAL(r_size) :: ecc,ecc2,fcc,fcc2,theta,theta_rotate,sigma_min
    REAL(r_size) :: dist_zero_a,dist_zero_b,dist_min
    REAL(r_size) :: sigma_a,sigma_b
    REAL(r_size) :: minr,maxr,xdis,fcc0,fcc1,maxdN,maxdS,xrad
    REAL(r_size), PARAMETER :: cmpersec2kmperday=0.864d0 !, days = 5.0d0
    !STEVE: for initializing splits of model grid:
    LOGICAL :: splitlon = .false. ! initialize
    LOGICAL :: splitlonL = .false., splitlonR = .false. ! initialize
    LOGICAL :: splitlat = .false. ! initialize
    LOGICAL :: fulllon = .false. ! initialize
    !STEVE:
    LOGICAL :: dodebug = .false.
    !debug TEST:
    INTEGER :: nn_old,imin_old,imax_old,jmin_old,jmax_old
    REAL(r_size) :: minlon_old,maxlon_old,minlat_old,maxlat_old

    !-----------------------------------------------------------------------------
    ! INITIALIZE
    !-----------------------------------------------------------------------------
    if( nobs > 0 ) then
       ALLOCATE(nobs_use(nobs))
    endif
    nn = 0

    !-----------------------------------------------------------------------------
    ! TEST: For comparison (and debugging) call old Miyoshi version:
    !-----------------------------------------------------------------------------
    if (dodebug) CALL obs_local_setup_old(ij,nn_old,minlon_old,maxlon_old,minlat_old,maxlat_old,imin_old,imax_old,jmin_old,jmax_old)

    !-----------------------------------------------------------------------------
    ! Set model coordinates
    !-----------------------------------------------------------------------------
    xlat = lat1(ij)
    xlon = lon1(ij)
    if (dodebug) WRITE(6,*) "---------------------------------- ij = ", ij

    !
    ! data search (NOTE: this only wraps in the longitude direction)
    ! Use bounding box first to reduce obs considered.
    !
    minlon = xlon - dlon_zero(ij)
    maxlon = xlon + dlon_zero(ij)
    minlat = xlat - dlat_zero !STEVE: this should be changed to be (ij) dependent
    maxlat = xlat + dlat_zero

    if (dodebug) then
       WRITE(6,*) "---minlon = ", minlon
       WRITE(6,*) "---maxlon = ", maxlon
       WRITE(6,*) "---minlat = ", minlat
       WRITE(6,*) "---maxlat = ", maxlat

       WRITE(6,*) "+++minlon = ", minlon_old
       WRITE(6,*) "+++maxlon = ", maxlon_old
       WRITE(6,*) "+++minlat = ", minlat_old
       WRITE(6,*) "+++maxlat = ", maxlat_old

       WRITE(6,*) "nn_old   = ", nn_old
       WRITE(6,*) "imin_old = ", imin_old
       WRITE(6,*) "imax_old = ", imax_old
       WRITE(6,*) "jmin_old = ", jmin_old
       WRITE(6,*) "jmax_old = ", jmax_old
    endif

    !-----------------------------------------------------------------------------
    ! Handle the case when the bounding box is split of the edge of the grid
    !-----------------------------------------------------------------------------
    !STEVE: ISSUE
    !STEVE: we need handling of the fold in the arctic due to the Murray tripolar grid.
    fulllon = .false.
    splitlonL = .false.
    splitlonR = .false.
    splitlat = .false.
    if (maxlon - minlon > lonf - lon0) then
       fulllon = .true.
       if (dodebug) then
          WRITE(6,*) "FullLon."
          WRITE(6,*) "xlon = ", xlon
          WRITE(6,*) "xlat = ", xlat
       endif
       minlon = lon0
       maxlon = lonf
    else

       if (minlon < lon0) then ! Local region overlaps on left
          if (dodebug) WRITE(6,*) "split minlon = ", minlon
          splitlonL = .true.
          minlon = REAL(lonf - abs(lon0 - minlon) + wrapgap,r_size)
       endif

       if (maxlon > lonf) then ! Local region overlaps on right
          if (dodebug) WRITE(6,*) "split maxlon = ", maxlon
          if (splitlonL) WRITE(6,*) "WARNING: lon already split. ij = ", ij
          splitlonR = .true.
          maxlon = REAL(lon0 + abs(maxlon - lonf) - wrapgap,r_size)
       endif

       if (minlat < lat0) then ! Local region overlaps on bottom
          splitlat= .true.
          minlat = lat0
       endif

       if (maxlat > latf) then ! Local region overlaps on top
          if (splitlat) WRITE(6,*) "WARNING: lat already split. ij = ", ij
          splitlat = .true.
          maxlat = latf
       endif

    endif

    if (splitlat) then
       ! Too close to pole, need to work out the details of this
       ! For now, cut off the local region at the pole
       WRITE(6,*) "letkf_local.f90::obs_local: Grid point is close to pole."
    endif

    ! Find jmin and jmax
    do jmin=1,nlat-2
       if(minlat < lat(jmin+1)) exit
    enddo
    do jmax=1,nlat-2
       if(maxlat < lat(jmax+1)) exit
    enddo
    nn = 1

    if ( (splitlonL .or. splitlonR) .and. .not. fulllon) then
       if (dodebug) WRITE(6,*) "splitlonL = ", splitlonL
       if (dodebug) WRITE(6,*) "splitlonR = ", splitlonR

       ! Do left
       imin = 1
       do imax=1,nlon-1
          if(maxlon < lon(imax+1)) exit
       enddo
       if (dodebug) then
          WRITE(6,*) "splitlon left: nn = ", nn
          WRITE(6,*) "xlon = ", xlon
          WRITE(6,*) "minlon = ", minlon
          WRITE(6,*) "maxlon = ", maxlon
          WRITE(6,*) "imin = ", imin
          WRITE(6,*) "imax = ", imax
          WRITE(6,*) "jmin = ", jmin
          WRITE(6,*) "jmax = ", jmax
       endif
       if( nobs > 0 ) CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)

       ! Do right
       do imin=1,nlon-1
          if(minlon < lon(imin+1)) exit
       enddo
       imax = nlon
       if (dodebug) then
          WRITE(6,*) "splitlon right: nn = ", nn
          WRITE(6,*) "xlon = ", xlon
          WRITE(6,*) "minlon = ", minlon
          WRITE(6,*) "maxlon = ", maxlon
          WRITE(6,*) "imin = ", imin
          WRITE(6,*) "imax = ", imax
          WRITE(6,*) "jmin = ", jmin
          WRITE(6,*) "jmax = ", jmax
       endif
       if( nobs > 0 ) CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)

    elseif ( .not. fulllon ) then
       ! The local range is entirely contained within the global domain
       ! Find the min and max latitudes
       do jmin=1,nlat-2
          if(minlat < lat(jmin+1)) exit
       enddo
       do jmax=jmin,nlat-2
          if(maxlat < lat(jmax+1)) exit
       enddo

       ! Find the min and max longitudes
       do imin=1,nlon-1
          if(minlon < lon(imin+1)) exit
       enddo
       do imax=imin,nlon-1
          if(maxlon < lon(imax+1)) exit
       enddo

       if( nobs > 0 ) CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)

    else
       ! The domain is the entire circle around the globe (zonally)
       ! Find the min and max latitudes
       do jmin=1,nlat-2
          if(minlat < lat(jmin+1)) exit
       enddo
       do jmax=jmin,nlat-2
          if(maxlat < lat(jmax+1)) exit
       enddo

       if (dodebug) then
          WRITE(6,*) "Doing FullLon..."
       endif
       imin=1
       imax=nlon
       if( nobs > 0 ) CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
    endif
    nn = nn-1
    !STEVE: end rewrite

    ! If no observations remain, then we're done.
    if(nn < 1) then
       nobsl = 0
       RETURN
    endif

    !----------------------------------------------------------------------------
    ! Cycle through all observations to identify which should be kept
    !----------------------------------------------------------------------------
    !STEVE: most of the localization section has been completely edited for (OCEAN)
    !STEVE: This should eventually be replaced with a tree-based search algorithm (e.g. R-Tree, kd-tree)
    !STEVE: (future) use custom localization with CGAL/BOOST algorithms
    nobsl = 0
    do n=1,nn
       !---------------------------------------------------------------------------
       ! Observational localization Distance Cutoff
       !---------------------------------------------------------------------------
       olat = obslat(nobs_use(n))
       olon = obslon(nobs_use(n))
       olev = obslev(nobs_use(n))
       oelm = obselm(nobs_use(n))

       !---------------------------------------------------------------------------
       ! variable localization
       !---------------------------------------------------------------------------
       !STEVE: ISSUE: this should be handled in a more generic way so new
       !              observations don't requrie editing here.
       SELECT CASE(NINT(oelm))
       CASE(id_u_obs)
          iobs=1
       CASE(id_v_obs)
          iobs=2
       CASE(id_t_obs)
          iobs=3
       CASE(id_s_obs)   !(OCEAN)
          iobs=4
       CASE(id_ssh_obs) !(OCEAN)
          iobs=5
       CASE(id_sst_obs) !(OCEAN)
          iobs=6
       CASE(id_sss_obs) !(OCEAN)
          iobs=7
       CASE(id_eta_obs) !(OCEAN)
          iobs=8
       CASE(id_aice_obs)
          iobs=1
       CASE(id_hice_obs)
          iobs=1
       CASE DEFAULT
          WRITE(6,*) "letkf_local.f90 :: there is no variable localization for obs-type :: ", oelm
          WRITE(6,*) "letkf_local.f90 :: exitING..."
          STOP 95
       END SELECT
       if(var_local(iobs) < TINY(var_local)) CYCLE  ! Skip obs that are set to "0" impact on this model variable.

       !---------------------------------------------------------------------------
       ! vertical localization
       !---------------------------------------------------------------------------
       !STEVE: make vertical localization depth dependent
       !STEVE: Could alternatively treat surface obs as if they occur at depth 0, regardless of model's top level
       !STEVE: ISSUE: need to make this more general, define vertical localization types for specific obs elsewhere
       if(NINT(oelm) == id_ssh_obs) then
          dlev = 0.0d0 ! allow all levels to be influenced by ssh
       else if(NINT(oelm) == id_sst_obs) then
          dlev = ABS( olev - lev(ilev) )
          !WRITE(6,*) "obs_local:: SST ob, dlev = ",dlev
       else if(NINT(oelm) == id_sss_obs) then
          dlev = ABS( olev - lev(ilev) )
       else if(NINT(oelm) == id_u_obs .or. &
            NINT(oelm) == id_v_obs .or. &
            NINT(oelm) == id_t_obs .or. &
            NINT(oelm) == id_s_obs   ) then
          dlev = ABS( olev - lev(ilev) )
       else
          dlev = 0.0d0
       endif
       if(dlev > dist_zerov) CYCLE

       !---------------------------------------------------------------------------
       ! horizontal localization
       !---------------------------------------------------------------------------
       horizontal_localization : if (localization_method .eq. 1) then
          !STEVE: make horizontal localization latitude dependent
          ! STEVE: make sigma_obs a linear/lookup function of latitude
          dist_min = sigma_obs0 * (SQRT(10.0d0/3.0d0) * 2.0d0)
          minr = dist_min
          maxr = dist_zero
          maxdN = abs( (90.0d0)*(pi/180.0d0)*re)
          maxdS = abs((-90.0d0)*(pi/180.0d0)*re)

          ! Shrink radius far from equator
          ! Shrink foci far from equator
          xdis = abs(xlat)*(pi/180.0d0)*re
          if (xlat >= 0) then
             xrad = (1 - xdis/maxdN)*maxr + (xdis/maxdN)*minr
          else
             xrad = (1 - xdis/maxdS)*maxr + (xdis/maxdS)*minr
          endif

          sigma_a = xrad / (SQRT(10.0d0/3.0d0) * 2.0d0)
          sigma_b = sigma_a
          dist_zero_a = xrad

          !-------------------------------------------------------------------------
          ! Compute the great circle distance between the grid point and the observation
          !-------------------------------------------------------------------------
          CALL com_distll_1(olon,olat,xlon,xlat,dist)

          if (.false.) then !(modulo(n,10000) .eq. 0) then
             !STEVE: DEBUG: print out the important values for a selection of obs
             print *, "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-="
             print *, "DEBUG letkf_local.f90..."
             print *, "n = ", n
             print *, "dist_min = ", dist_min
             print *, "sigma_obs0 = ", sigma_obs0
             print *, "minr = ", minr
             print *, "maxr = ", maxr
             print *, "maxdN = ", maxdN
             print *, "maxdS = ", maxdS
             print *, "xlat = ", xlat
             print *, "xdis = ", xdis
             print *, "xrad = ", xrad
             print *, "sigma_a = ", sigma_a
             print *, "sigma_b = ", sigma_b
             print *, "sigma_obs = ", sigma_obs
             print *, "dist_zero_a = ", dist_zero_a
             print *, "dist = ", dist
             !       print *, "dist > dist_zero_a = ", dist > dist_zero_a
             print *, "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-="
          endif

          if(dist > dist_zero_a) CYCLE  !Points are outside of radius

       else !STEVE: use the original (default) localization

          CALL com_distll_1(olon,olat,xlon,xlat,dist)
          if(dist > dist_zero ) CYCLE

       endif horizontal_localization

       ! STEVE: ADD CHECK FOR OBSERVATIONS THAT ARE OCCLUDED BY LAND!
       ! STOLE atlpac from SODA, in the future, implement a general method
       ! for occluding points that can't be reached by a SPM in the local range
       blocked_by_land = .false.

       !!!!!!!!!!!!!!!!!!!!!!!!!!!!! DANGER !!!!!!!!!!!!!!!!!!!!!!!!!!
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!! DANGER !!!!!!!!!!!!!!!!!!!!!!!!!!
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!! DANGER !!!!!!!!!!!!!!!!!!!!!!!!!!
       ! Guillaume: There's a bug in the routines comented out below, discontinuity appear along the meridian in a small box bounded
       !            by ~ Ghana/Nigeria/Cameroon

!!$       CALL atlpac(xlat,xlon,lxpa)
!!$       CALL atlpac(olat,olon,lopa)
!!$       IF (  lxpa .eq. 1 .and. lopa .eq. 2 &        !in caribbean, pacific and atlantic
!!$            .or. lxpa .eq. 2 .and. lopa .eq. 1 &      !in caribbean, atlantic and pacific
!!$            ) blocked_by_land = .true.
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!! END DANGER !!!!!!!!!!!!!!!!!!!!!!!!!!
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!! END DANGER !!!!!!!!!!!!!!!!!!!!!!!!!!
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!! END DANGER !!!!!!!!!!!!!!!!!!!!!!!!!!
       IF (blocked_by_land) CYCLE                   !STEVE: the two points are in atl and pac

       !STEVE: ISSUE: update this to read in a table with basin ids to
       !              only assimilate data in current or adjacent basin

       !--------------------------- End of Observation Culling -----------------------!

       !---------------------------------------------------------------------------
       ! Collect all identifed local observations into data structures for output
       !---------------------------------------------------------------------------
       nobsl = nobsl + 1
       hdxf(nobsl,:) = obshdxf(nobs_use(n),:)
       dep(nobsl)    = obsdep(nobs_use(n))
       tmperr=obserr(nobs_use(n))
       rdiag(nobsl) = tmperr * tmperr
       if (ALLOCATED(obs_useidx)) then
          obs_useidx(nobsl) = nobs_use(n)
       endif

       !---------------------------------------------------------------------------
       ! Observational localization (weighting)
       !---------------------------------------------------------------------------
       !
       ! Note: var_local scales the localization weighting based on the parameter
       ! set in letkf_tools.f90. A row corresponding to the model parameter is
       ! input to this subroutine, and the column indicates the proportion of that
       ! type of observation to use.
       observation_localization : if (localization_method .eq. 1 ) then
          if (DO_NO_VERT_LOC) then
             rloc(nobsl) =EXP(-0.5d0 * (dist/sigma_a)**2) * var_local(iobs)
          elseif(NINT(oelm) == id_sst_obs) then    ! GUILLAUME: if sst obs ...
             rloc(nobsl) =EXP(-0.5d0 * ((dist/sigma_a)**2 + (dlev/sigma_obsv_sst)**2)) &
                  & * var_local(iobs)
          elseif(NINT(oelm) == id_eta_obs) then    ! GUILLAUME: if adt obs 1/4 loc scales of prof ...
             rloc(nobsl) =0.25d0*EXP(-0.5d0 * ((dist/sigma_a)**2 + (dlev/sigma_obsv_sst)**2)) &
                  & * var_local(iobs)
          elseif(NINT(oelm) == id_aice_obs) then    ! GUILLAUME: if aice obs ...
             !rloc(nobsl) =EXP(-0.5d0 * ((dist/(tmperr*sigma_a))**2 ))
             rloc(nobsl) =EXP(-0.5d0 * ((dist/(sigma_a))**2 ))
          else
             rloc(nobsl) =EXP(-0.5d0 * ((dist/sigma_a)**2 + (dlev/sigma_obsv)**2)) &
                  & * var_local(iobs)
          endif

       elseif (localization_method .eq. 0) then
          !STEVE: this is R^2 and the R localization gaussian function
          rloc(nobsl) =EXP(-0.5d0 * ((dist/sigma_obs)**2 + (dlev/sigma_obsv)**2)) &
               & * var_local(iobs)
       else

          print *, "ERROR:: Localization method not supported. localization_method = ", localization_method
          STOP 3

       endif observation_localization

       !STEVE: debugging error... keeping this around to prevent it
       !                          from occuring again and going unnoticed
       if (rloc(nobsl) > 1) then
          WRITE(6,*) "rloc(nobsl) > 1 !"
          WRITE(6,*) "localization_method = ", localization_method
          WRITE(6,*) "nobsl = ", nobsl
          WRITE(6,*) "dist = ", dist
          WRITE(6,*) "sigma_a = ", sigma_a
          WRITE(6,*) "sigma_obs = ", sigma_obs
          WRITE(6,*) "var_local(iobs) = ", var_local(iobs)
          WRITE(6,*) "rloc(nobsl) = ", rloc(nobsl)
          WRITE(6,*) "letkf_local.f90:: exitING.."
          STOP 93
       endif

    enddo

    !----------------------------------------------------------------------------
    !STEVE: this should never happen, if it does something went wrong
    !----------------------------------------------------------------------------
    if( nobsl > nobstotal ) then
       WRITE(6,'(A,I5,A,I5)') 'FATAL ERROR, NOBSL=',nobsl,' > NOBSTOTAL=',nobstotal
       WRITE(6,*) 'IJ,NN,TVNN=', ij, nn, tvnn
       STOP 99
    endif

    if( nobs > 0 ) then
       DEALLOCATE(nobs_use)
    endif

  END SUBROUTINE obs_local

  PURE SUBROUTINE obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
    !===============================================================================
    ! Identify the observations within the local region
    !===============================================================================
    INTEGER,INTENT(IN) :: imin,imax,jmin,jmax
    INTEGER,INTENT(INOUT) :: nn, nobs_use(nobs)
    INTEGER :: j,n,ib,ie,ip

    ! Cycle through each latitude
    do j=jmin,jmax
       ! Find the number of accumulated obs at the bottom of the range
       if(imin > 1) then
          ib = nobsgrd(imin-1,j)+1
       else
          ! Wrap around to the previous latitude at the last longitude
          if(j > 1) then
             ib = nobsgrd(nlon,j-1)+1
          else
             ib = 1
          endif
       endif
       ! Find the number of accumulated obs at the top of the range
       ie = nobsgrd(imax,j)

       ! Subtract to get the number of obs in this region
       n = ie - ib + 1

       if(n == 0) CYCLE !there are no obs here

       do ip=ib,ie
          if(nn > nobs) then
             !       WRITE(6,*) 'FATALERROR, NN > NOBS', NN, NOBS
             !       stop 1  !STEVE: (added)
          endif
          ! Index for observation used
          nobs_use(nn) = ip
          ! Count up the total obs used so far
          nn = nn + 1
       enddo
    enddo

    RETURN
  END SUBROUTINE obs_local_sub

  SUBROUTINE obs_local_setup_old(ij,nn,minlon,maxlon,minlat,maxlat,imin,imax,jmin,jmax)
    !===============================================================================
    ! Original Miyoshi code
    ! Project global observations to local
    !     (hdxf_g,dep_g,rdiag_g) -> (hdxf,dep,rdiag)
    !===============================================================================
    IMPLICIT NONE
    INTEGER,INTENT(IN) :: ij
    INTEGER,INTENT(OUT) :: nn
    REAL(r_size), INTENT(OUT) :: minlon,maxlon,minlat,maxlat
    INTEGER, INTENT(OUT) :: imin,imax,jmin,jmax
    INTEGER,ALLOCATABLE:: nobs_use(:)
    INTEGER :: n,nobsl,im
    !STEVE: for (OCEAN):
    REAL(r_size) :: xlat,xlon
    LOGICAL :: dodebug = .false.

    !
    ! INITIALIZE
    !
    if( nobs > 0 ) then
       ALLOCATE(nobs_use(nobs))
    endif
    !
    ! data search
    !
    minlon = lon1(ij) - dlon_zero(ij)
    maxlon = lon1(ij) + dlon_zero(ij)
    minlat = lat1(ij) - dlat_zero
    maxlat = lat1(ij) + dlat_zero

    do jmin=1,nlat-2
       if(minlat < lat(jmin+1)) exit
    enddo
    do jmax=1,nlat-2
       if(maxlat < lat(jmax+1)) exit
    enddo
    nn = 1
    if(minlon >= lon0 .AND. maxlon <= lonf) then
       do imin=1,nlon-1
          if(minlon < lon(imin+1)) exit
       enddo
       do imax=1,nlon-1
          if(maxlon < lon(imax+1)) exit
       enddo
       if( nobs > 0 ) &
            & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
    else if(minlon >= lon0 .AND. maxlon > lonf) then
       do imin=1,nlon-1
          if(minlon < lon(imin+1)) exit
       enddo
       maxlon = maxlon - 360.0d0
       if(maxlon > lonf) then
          imin = 1
          imax = nlon
          if( nobs > 0 ) &
               & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
       else
          do imax=1,nlon-1
             if(maxlon < lon(imax+1)) exit
          enddo
          if(imax > imin) then
             imin = 1
             imax = nlon
             if( nobs > 0 ) &
                  & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
          else
             imin = 1
             if( nobs > 0 ) &
                  & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
             do imin=1,nlon-1
                if(minlon < lon(imin+1)) exit
             enddo
             imax = nlon
             if( nobs > 0 ) &
                  & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
          endif
       endif
    else if(minlon < lon0 .AND. maxlon <= lonf) then
       do imax=1,nlon-1
          if(maxlon < lon(imax+1)) exit
       enddo
       minlon = minlon + 360.0d0
       if(minlon < lon0) then
          imin = 1
          imax = nlon
          if( nobs > 0 ) &
               & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
       else
          do imin=1,nlon-1
             if(minlon < lon(imin+1)) exit
          enddo
          if(imin < imax) then
             imin = 1
             imax = nlon
             if( nobs > 0 ) &
                  & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
          else
             imin = 1
             if( nobs > 0 ) &
                  & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
             do imin=1,nlon-1
                if(minlon < lon(imin+1)) exit
             enddo
             imax = nlon
             if( nobs > 0 ) &
                  & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
          endif
       endif
    else
       maxlon = maxlon - 360.0d0
       minlon = minlon + 360.0d0
       if(maxlon > lonf .OR. minlon < lon0) then
          imin = 1
          imax = nlon
          if( nobs > 0 ) &
               & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
       else
          do imin=1,nlon-1
             if(minlon < lon(imin+1)) exit
          enddo
          do imax=1,nlon-1
             if(maxlon < lon(imax+1)) exit
          enddo
          if(imin > imax) then
             imin = 1
             imax = nlon
             if( nobs > 0 ) &
                  & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
          else
             if( nobs > 0 ) &
                  & CALL obs_local_sub(imin,imax,jmin,jmax,nn,nobs_use)
          endif
       endif
    endif
    nn = nn-1
    if(nn < 1) then
       nobsl = 0
       RETURN
    endif
  END SUBROUTINE obs_local_setup_old

  !(OCEAN) STEVE: add checks for atlantic/pacific basin boundary
  PURE SUBROUTINE atlpac (xlat, xlon_in, lxap)
    REAL(r_size), INTENT(IN) :: xlat, xlon_in
    REAL(r_size), INTENT(OUT) :: lxap
    REAL(r_size) :: xlon

    ! Ensure the longitude is specified on a 0-360 grid:
    xlon = modulo(xlon_in,360.0)

    ! STEVE: Stolen from SODA:
    ! ISSUE: use until we have a general method for managing land-blocked ocean basins...
    !=================================================================
    ! X. Cao 12/9/99
    !
    !   to make a mark to the location of a point in Caribbean area
    ! (xlat.gt.-2..and.xlat.lt.32..and.xlon.gt.245..and.xlon.lt.295.)
    ! to indicate if it is in Atlantic ocean (1) or in Pacific ocean (2)
    ! or out of Caribbean area (0)
    !=================================================================
    !
    lxap=0
    !
    ! -- Atlantic? Pacific?
    !
    if(xlat.gt.-2.0.and.xlat.le.8.5) then
       if(xlon.lt.285.) then
          lxap=2
       else
          lxap=1
       endif
    endif

    if(xlat.gt.8.5.and.xlat.le.15.5) then
       if(xlon.lt.276.) then
          lxap=2
       else
          lxap=1
       endif
    endif

    if(xlat.gt.15.5.and.xlat.le.19.5) then
       if(xlon.lt.270.) then
          lxap=2
       else
          lxap=1
       endif
    endif

    if(xlat.gt.19.5.and.xlat.le.32.0) then
       if(xlon.lt.258.) then
          lxap=2
       else
          lxap=1
       endif
    endif

  END SUBROUTINE atlpac

END MODULE letkf_local


! -*- mode: F90; mode: font-lock -*-
! ------------------------------------------------------------------------------
! $Id$
! ------------------------------------------------------------------------------
! Module trans_module
! ------------------------------------------------------------------------------
! Code area 2: matrices
! ------------------------------------------------------------------------------

!!****h* Conquest/trans_module *
!!  NAME
!!   trans_module
!!  PURPOSE
!!   Routines associated with taking the global transpose of matrices
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   24/01/00
!!  MODIFICATION HISTORY
!!   03/03/00 by D.R.Bowler
!!    Finishing up transposes
!!   12/04/00 by DRB
!!    Put itran_addr into trans_remote type
!!   20/04/00 by DRB
!!    Changed send_pair_info to not use pairs type
!!   21/06/2001 dave
!!    Added ROBODoc header and RCS Id and Log tags and cq_abort
!!   24/06/2002 dave
!!    Changed index_transpose to give exact array size and added RCS static tag
!!   2018/10/03 16:52 dave
!!    Fixing MPI tags to obey the standard
!!***
module trans_module

  use GenComms, ONLY: cq_abort, my_barrier

  implicit none

contains

!!****f* trans_module/a_and_b *
!!
!!  NAME
!!   a_and_b
!!  USAGE
!!
!!  PURPOSE
!!   makes tables to identify a and b: a is the halo atom on the
!!   sending node (hence the primary atom on the receiving node),
!!   and b is the primary atom on the sending node (hence the halo
!!   atom on the receiving node).
!!   For each primary - halo pair, the tables are (within adata):
!!     ipart_a():   sim-cell CC label of a partition
!!     iseq_a():    a seq. no. in his partition
!!     ipart_b(): CC label of b partition relative to a
!!                    partition in GCS of receiving node
!!     iseq_b():  b seq. no. in her partition
!!  INPUTS
!!
!!
!!  USES
!!
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   24/01/00
!!  MODIFICATION HISTORY
!!   21/06/2001 dave
!!    Added ROBODoc header
!!  SOURCE
!!
  subroutine a_and_b(mynode,trans,halo,data,pairs,prim,gcs)

    use datatypes
    use matrix_module
    use basic_types

    implicit none

    ! Passed variables
    type(matrix_trans) :: trans
    type(matrix_halo)  :: halo
    type(trans_remote) :: data
    type(pair_data)    :: pairs(:)
    type(primary_set)  :: prim
    type(cover_set)    :: gcs

    integer(integ) :: mynode

    ! Local variables
    integer(integ) :: na,ia,npr,nr,nnd_rem,ncoveryz,ncoveryz_rem
    integer(integ) :: np, ind_part,ind_covera,nxa,nya,nza,nxb,nyb,nzb
    integer(integ) :: n,ind_seq,i,ip,ind_coverb,nxd,nyd,nzd,nnpr

    ! Make a useful constant
    ncoveryz=gcs%ncovery*gcs%ncoverz
    na=0
    ia=0
    npr=0
    ! Make the _pair,_seq arrays
    data%i_nd_pair_addr(1)=1
    do nr=1,data%n_rem_node  ! Loop over remote nodes
       pairs(nr)%length = 0
       nnpr=0
       nnd_rem=data%list_rem_node(nr)
       ncoveryz_rem=gcs%ncover_rem(2+(nnd_rem-1)*3)* &
            gcs%ncover_rem(3+(nnd_rem-1)*3)
       do np=1,data%nhp_for_node(nr) ! Loop over halo partitions for this node
          na=na+1
          ind_part=halo%lab_hcell(na)
          ind_covera=halo%lab_hcover(na)-1
          nxa=ind_covera/ncoveryz
          nya=(ind_covera-nxa*ncoveryz)/gcs%ncoverz
          nza=ind_covera-nxa*ncoveryz-nya*gcs%ncoverz
          do n=1,halo%nh_part(na)  ! Loop over atoms in partitions
             ia=ia+1 ! Goes over all atoms in halo
             ind_seq=halo%j_seq(ia)
             do i=1,trans%n_hnab(ia) ! Loop over neighbours of each atom
                npr=npr+1
                nnpr=nnpr+1
                pairs(nr)%ipart_a(nnpr)=ind_part  ! Local halo atom, a
                pairs(nr)%iseq_a(nnpr)=ind_seq
                ip=trans%i_prim(npr)
                pairs(nr)%submat(nnpr)=halo%ndimj(ia)*halo%ndimi(ip)
                pairs(nr)%length = pairs(nr)%length + pairs(nr)%submat(nnpr)
                ! iprim_part gives the GCS partn (CC-label) of primary atom b
                ind_coverb=gcs%iprim_group(ip)-1  ! Local primary atom, b
                nxb=ind_coverb/ncoveryz
                nyb=(ind_coverb-nxb*ncoveryz)/gcs%ncoverz
                nzb=ind_coverb-nxb*ncoveryz-nyb*gcs%ncoverz
                ! nxd is the offset of the partition B from partition A
                nxd=nxb-nxa
                nyd=nyb-nya
                nzd=nzb-nza
                pairs(nr)%ipart_b(nnpr)=nxd*ncoveryz_rem+ &
                     nyd*gcs%ncover_rem(3+(nnd_rem-1)*3)+nzd
                ! iprim_seq gives the seq number in its partn of primary atom b
                pairs(nr)%iseq_b(nnpr)=prim%iprim_seq(ip)
             enddo
          enddo
       enddo
      if(nr.lt.data%n_rem_node) then
         data%i_nd_pair_addr(nr+1)=data%i_nd_pair_addr(nr)+pairs(nr)%length
      endif
    enddo
    return
  end subroutine a_and_b
!!***

!!****f* trans_module/send_pair_info *
!!
!!  NAME
!!   send_pair_info
!!  USAGE
!!
!!  PURPOSE
!!   Send arrays needed by sbrt index_transpose. Data to be sent
!!   are the tables ipart_a(), iseq_a(), ipart_b(), and iseq_b(),
!!   contained within the data structure. For the meanings of these,
!!   see sbrts a_and_b and index_transpose.
!!  INPUTS
!!
!!
!!  USES
!!
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!
!!  MODIFICATION HISTORY
!!   21/06/2001 dave
!!    Added ROBODoc header and cq_abort
!!   2008/02/11 17:07 dave
!!    Added full set of requests passed in from trans_ini for non-blocking sends
!!   2018/10/03 16:53 dave
!!    Changing MPI tags to 1 and 2 (all that we need)
!!  SOURCE
!!
  subroutine send_pair_info(mynode,pairsind,trans,nreq)

    use mpi
    use datatypes
    use matrix_module
    use matrix_comms_module, ONLY : mx_msg_per_part

    implicit none

    ! Passed variables
    type(trans_remote) :: trans
    integer(integ) :: pairsind(:)
    integer(integ) :: mynode
    integer, dimension(2*trans%n_rem_node) :: nreq

    ! Local variables
    integer(integ) :: nr,nnd_rem,tag,ierr,nn,irc

    tag = 0
    ! Send pairs data to halo nodes
    do nr=1,trans%n_rem_node
       nnd_rem=trans%list_rem_node(nr)
       if(nnd_rem/=mynode) then
          call MPI_issend(pairsind(4*(trans%i_pair_addr(nr)-1)+1), &
               4*trans%n_pair(nr), &
               MPI_INTEGER,nnd_rem-1,tag+1,MPI_COMM_WORLD,nreq(2*nr-1),ierr)
          if(ierr/=MPI_Success) call cq_abort('send_pair_info: error sending')
          call MPI_issend(trans%i_nd_pair_addr(nr),1,MPI_INTEGER, &
               nnd_rem-1,tag+2,MPI_COMM_WORLD,nreq(2*nr),ierr)
          if(ierr/=MPI_Success) call cq_abort('send_pair_info: error sending')
       endif
    enddo
    call my_barrier ! Make sure everyone's here
    return
  end subroutine send_pair_info
!!***

!!****f* trans_module/index_transpose *
!!
!!  NAME
!!   index_transpose
!!  USAGE
!!
!!  PURPOSE
!!   Fetches the remote-address table i_pair_rem() and creates
!!   the address table itran_addr() used in sbrt mat_tran.
!!  INPUTS
!!
!!
!!  USES
!!
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!
!!  MODIFICATION HISTORY
!!   21/06/2001 dave
!!    Added ROBODoc header and cq_abort
!!   24/06/2002 dave
!!    Changed copy of ind to give array dimensions explicitly
!!   2006/09/07 11:51 dave
!!    Added halo_rem to use the halo of the transposed matrix
!!   2018/10/03 16:53 dave
!!    Changing MPI tags to 1 and 2 (all that we need)
!!  SOURCE
!!
  subroutine index_transpose(mx_iprim,mynode,data,halo, &
       halo_rem,pairsind,pairs,parts,prim,gcs)

    use mpi
    use matrix_module
    use basic_types
    use matrix_comms_module, ONLY : mx_msg_per_part

    implicit none

    ! Passed variables
    integer(integ) :: mx_iprim,mynode
    integer(integ) :: pairsind(:)
    type(pair_data)    :: pairs(:)
    type(trans_remote) :: data
    type(matrix_halo)  :: halo, halo_rem
    type(group_set) :: parts
    type(primary_set) :: prim
    type(cover_set) :: gcs

    ! Local variables
    integer(integ) :: nnd_rem,tag,nn,ic,nr,iiip,ip,ierr
    integer(integ) :: noffx,noffy,noffz,jjjp,ih,stat
    integer :: nrstat(MPI_STATUS_SIZE)
    ! Temporary local storage
    integer(integ), target :: ind(4*data%mx_pair)
    integer(integ), pointer :: ipart_a_rem(:),iseq_a_rem(:)
    integer(integ), pointer :: ipart_b_rem(:),iseq_b_rem(:)

    ind = 0
    tag = 0
    do nr=1,data%n_rem_node  ! Loop over relevant remote nodes
       ipart_a_rem => ind(1:data%n_pair(nr))
       iseq_a_rem  => ind(data%n_pair(nr)+1:2*data%n_pair(nr))
       ipart_b_rem => ind(2*data%n_pair(nr)+1:3*data%n_pair(nr))
       iseq_b_rem  => ind(3*data%n_pair(nr)+1:4*data%n_pair(nr))
       nnd_rem=data%list_rem_node(nr)
       ! Receive info about atom pairs
       ipart_a_rem = 0
       ipart_b_rem = 0
       iseq_a_rem = 0
       iseq_b_rem = 0
       if(nnd_rem/=mynode) then
          call MPI_recv(ind,4*data%n_pair(nr),MPI_INTEGER,&
               nnd_rem-1,tag+1,MPI_COMM_WORLD,nrstat,ierr)
          if(ierr/=MPI_Success) call cq_abort('index_trans: error in MPI_recv')
          call MPI_recv(data%rem_pair_addr(nr),1,MPI_INTEGER, &
               nnd_rem-1,tag+2,MPI_COMM_WORLD,nrstat,ierr)
          if(ierr/=MPI_Success) call cq_abort('index_trans: error in MPI_recv')
       else
          ind(1:4*data%n_pair(nr)) = pairsind(4*(data%i_pair_addr(nr)-1)+1: 4*(data%i_pair_addr(nr)-1)+4*data%n_pair(nr))
       endif
       ! Make address itran_addr() for start of data for each pair
       ic=data%i_pair_addr(nr)
       do nn=1,data%n_pair(nr)
          iiip=parts%i_cc2seq(ipart_a_rem(nn))
          ip=prim%nm_nodbeg(iiip)+iseq_a_rem(nn)-1
          noffx=1+gcs%nspanlx+prim%idisp_primx(iiip)
          noffy=1+gcs%nspanly+prim%idisp_primy(iiip)
          noffz=1+gcs%nspanlz+prim%idisp_primz(iiip)
          ! NB jjjp = jpart within m_kern_max
          jjjp=ipart_b_rem(nn)+ &
               (noffx-1)*gcs%ncovery*gcs%ncoverz+(noffy-1)*gcs%ncoverz+noffz
          if(jjjp>gcs%mx_gcover.OR.jjjp<1) then
             call cq_abort('index_trans: jjjp wrong ',jjjp,gcs%mx_gcover)
          endif
          if(halo_rem%i_hbeg(jjjp)+iseq_b_rem(nn)-1>gcs%mx_mcover.OR. &
               halo_rem%i_hbeg(jjjp)+iseq_b_rem(nn)-1<1) then
             call cq_abort('index_trans: i_halo wrong ', &
                  halo_rem%i_hbeg(jjjp)+iseq_b_rem(nn)-1,gcs%mx_mcover)
          endif
          ih=halo_rem%i_halo(halo_rem%i_hbeg(jjjp)+iseq_b_rem(nn)-1)
          if(ih>halo_rem%ni_in_halo) call cq_abort("Overrun in halo index: ",ih,halo_rem%ni_in_halo)
          pairs(nr)%submat(nn)=halo_rem%ndimi(ip)*halo_rem%ndimj(ih)
          if((ip-1)*halo_rem%ni_in_halo+ih>prim%mx_iprim*halo_rem%mx_halo.OR. &
               (ip-1)*halo_rem%ni_in_halo+ih<1) then
             call cq_abort('index_trans: i_h2d wrong ', &
                  (ip-1)*halo_rem%ni_in_halo+ih,prim%mx_iprim*halo_rem%mx_halo)
          endif
          data%itran_addr(ic+nn-1)=halo_rem%i_h2d((ip-1)*halo_rem%ni_in_halo+ih)
       enddo
    enddo ! End loop over remote nodes
    return
  end subroutine index_transpose
!!***
end module trans_module


subroutine mkexch(iband,ikpt, &
& omegap2,xkf,eigen,eigenq,wmax,nwpt,nqpt,ntpwndx,W, &
& nkpt,nkptq,npwt,npwtq,ncg,ncgq,npwarr,npwarrq,igmn,igmx,nbcore,nbocc,ncband, &
& bantot,bantotq,indxkbnd,indxkbndq,iqndx, &
& npwup,invpwndx,pwupmin,pwupmax,iqsymndx,nsym,pwsymndx,invpw2ndx, &
& kg,kgq,cg,cgq,kpt,kptq,indxkcg,indxkcgq,indxkpw,igndxq,ngkpt,ikndxq, &
& exch,ppcor,cor)
use geometry
implicit none
integer :: iband,ikpt
integer :: nkpt,nkptq,npwt,npwtq,ncg,ncgq,nbcore,nbocc,ncband,bantot,bantotq,ntpwndx,nwpt,nqpt,nsym,npwup
double precision :: omegap2,xkf,eigen(bantot),eigenq(bantotq),wmax
double complex :: W(nwpt,nqpt,ntpwndx)
integer :: igmn(3),igmx(3),ngkpt(3)
integer :: ikndxq(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: igndxq(nkptq,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
integer :: indxkpw(nkpt),indxkcg(nkpt),indxkcgq(nkptq)
integer :: indxkbnd(nkpt),indxkbndq(nkptq)
integer :: iqndx(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: npwarr(nkpt),npwarrq(nkptq)
integer :: pwupmin(3),pwupmax(3)
integer :: invpwndx(pwupmin(1):pwupmax(1),pwupmin(2):pwupmax(2),pwupmin(3):pwupmax(3))
integer :: iqsymndx(ngkpt(1),ngkpt(2),ngkpt(3)),invpw2ndx(npwup,npwup)
integer :: pwsymndx(npwup,2*nsym)
double precision :: kpt(3,nkpt),kptq(3,nkptq)
integer :: kg(3,npwt),kgq(3,npwtq)
double complex :: cg(ncg),cgq(ncgq)
double precision :: exch
double complex :: ppcor(nbcore+1:ncband),cor(nbcore+1:ncband)
double complex :: cse(-nwpt:nwpt)
double precision :: exch1
double complex :: ppcor1(nbcore+1:ncband),cor1(nbcore+1:ncband)
double complex :: cse1(-nwpt:nwpt)
double precision :: pi,fourpi,volelmnt,qq(3),qq2(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: ikk(3),iqq(3),ikp1(3),ikp2(3),ikp3(3),jqq(3),iqqp(3),iqv(3)
integer :: ipwgg(3),ishgg(3),igg(3),ictr(3)
integer :: jband,ipw,ix,iy,iz,ii,jj,kk,ie,iw,itet,iv
double precision :: ww,dw,brd
integer :: iqsing,nqgrid,isign,ipwa,ipwb,jjpw,iqpt
integer :: ikqpt
double complex :: cme,vme2(ngkpt(1),ngkpt(2),ngkpt(3)),ame2(ngkpt(1),ngkpt(2),ngkpt(3))
double precision :: gamma(3),pln(3),dist(3),falloff,st(6),cterm
double precision :: ekgg,xgg(3)
double precision :: ebkq(ngkpt(1),ngkpt(2),ngkpt(3)),omegat
double precision :: omega(ngkpt(1),ngkpt(2),ngkpt(3))
double complex :: cedenom
double precision :: wwq,ppfct
double complex :: wppint0(nbcore+1:ncband),wpp2int0(nbcore+1:ncband)
double complex :: wint0(nbcore+1:ncband),w2int0(nbcore+1:ncband)
double complex :: wppint(nbcore+1:ncband),wpp2int(nbcore+1:ncband)
double complex :: wint(nbcore+1:ncband),w2int(nbcore+1:ncband)
logical :: lx,lc,lqsing,lqcentr
parameter (pi=3.1415926535897932384626433832795, &
& fourpi=12.566370614359172953850573533118d0)

  ictr=ngkpt/2
  dw=wmax/dble(nwpt)

  gamma=(blat(1,:)+blat(2,:)+blat(3,:))/2.d0
  do ii=1,3
    jj=mod(ii,3)+1
    kk=mod(ii+1,3)+1
    pln(1)=blat(jj,2)*blat(kk,3)-blat(jj,3)*blat(kk,2)
    pln(2)=-blat(jj,1)*blat(kk,3)+blat(jj,3)*blat(kk,1)
    pln(3)=blat(jj,1)*blat(kk,2)-blat(jj,2)*blat(kk,1)
    dist(ii)=dot_product(gamma,pln)/sqrt(dot_product(pln,pln))
  enddo
  falloff=minval(dist)

  nqgrid=ngkpt(1)*ngkpt(2)*ngkpt(3)
  volelmnt=vol*nqgrid
  exch=0.d0
  do ie=nbcore+1,ncband
    ppcor(ie)=(0.d0,0.d0)
    cor(ie)=(0.d0,0.d0)
  enddo
  ikk=nint(kpt(:,ikpt)*dble(ngkpt))
!  do jband=nbcore+1,ncband
!  do jband=nbcore+1,nbocc
  do jband=1,1
!write(6,*) jband
    if (jband.gt.nbocc) then
      isign=1
    else
      isign=-1
    endif
!    do ipw=1,npwarr(ikpt)
    do ipw=1,1
      ipwgg=kg(:,indxkpw(ikpt)+ipw)
      xgg=dble(ipwgg)+dble(ikk)/dble(ngkpt)
      ekgg=0.d0
      do ii=1,3
      do jj=1,3
        ekgg=ekgg+xgg(ii)*bmet(ii,jj)*xgg(jj)
      enddo
      enddo
      if (ekgg.gt.8.0d0) cycle
      if (ipwgg(1).ge.pwupmin(1).and.ipwgg(1).le.pwupmax(1).and.  &
&         ipwgg(2).ge.pwupmin(2).and.ipwgg(2).le.pwupmax(2).and.  &
&         ipwgg(3).ge.pwupmin(3).and.ipwgg(3).le.pwupmax(3)) then
        ipwa=invpwndx(ipwgg(1),ipwgg(2),ipwgg(3))
        ipwb=invpwndx(ipwgg(1),ipwgg(2),ipwgg(3))
      else
        ipwa=0
        ipwb=0
      endif
!write(6,'(i4,5x,3i3)') ipw,ipwgg
!write(6,*) ngkpt
      do ix=1,ngkpt(1)
      do iy=1,ngkpt(2)
      do iz=1,ngkpt(3)
!      do ix=2,2
!      do iy=2,2
!      do iz=4,4
! determine k-q point and plane wave shift to remain in B.Z.
        iqq=(/ix,iy,iz/)-ngkpt/2
!write(6,'(3i3)') iqq
        ikp1=ikk-iqq
        ikp2=mod(ikp1+ngkpt/2,ngkpt)
        do ii=1,3
          if (ikp2(ii).le.0) ikp2(ii)=ikp2(ii)+ngkpt(ii)
        enddo
        ikqpt=ikndxq(ikp2(1),ikp2(2),ikp2(3))
        ikp3=nint(kptq(:,ikqpt)*dble(ngkpt))
        ishgg=nint(dble(ikp1-ikp3)/dble(ngkpt))
        igg=ipwgg-ishgg
!write(6,'(a,3i3)') 'ikk   = ',ikk
!write(6,'(a,3i3)') 'iqq   = ',iqq
!write(6,'(a,3i3)') 'ikp1  = ',ikp1
!write(6,'(a,3i3)') 'ikp2  = ',ikp2
!write(6,'(a,3i3)') 'ikp3  = ',ikp3
!write(6,'(a,3i3)') 'ishgg = ',ishgg
!write(6,'(a,3i3)') 'ipwgg = ',ipwgg
!write(6,'(a,3i3)') 'igg   = ',igg
!write(6,'(a,i5)') 'ikpt   = ',ikpt
!write(6,'(a,i5)') 'ikptq   = ',ikqpt
!write(6,'(a,3f10.5)') 'kk (red) = ',kpt(:,ikpt)
!write(6,'(a,3f10.5)') 'kp (red) = ',kptq(:,ikqpt)
! find q^2
        qq=(/0.d0,0.d0,0.d0/)
        do ii=1,3
          qq=qq+(kpt(ii,ikpt)-kptq(ii,ikqpt)+igg(ii))*blat(ii,:)
        enddo
        qq2(ix,iy,iz)=dot_product(qq,qq)
!write(6,'(a,3f10.5)') 'qq (red) = ',kpt(:,ikpt)-kptq(:,ikqpt)+igg
!write(6,'(a,3f10.5)') 'qq = ',qq
!write(6,'(a,f10.5)') 'qq^2 = ',qq2(ix,iy,iz)
! matrix elements
        call fndme(iband,ikpt,jband,ikqpt,igg, &
& nkpt,nkptq,npwt,npwtq,ncg,ncgq,npwarr,npwarrq,igmn,igmx, &
& kg,kgq,cg,cgq,indxkcg,indxkcgq,indxkpw,igndxq, &
& cme)
        ame2(ix,iy,iz)=cme*conjg(cme)
        vme2(ix,iy,iz)=fourpi*ame2(ix,iy,iz)/qq2(ix,iy,iz)
! intermediate state energy
        ebkq(ix,iy,iz)=eigenq(indxkbndq(ikqpt)+jband)
!write(6,'(a,3f10.5)') 'cme = ',cme
!write(6,'(a,3f10.5)') 'ame2 = ',ame2(ix,iy,iz)
!write(6,'(a,3f10.5)') 'vme2 = ',vme2(ix,iy,iz)
!write(6,'(3i3,2f15.10)') ix,iy,iz,cme
      enddo
      enddo
      enddo

      lx=jband.le.nbocc
      lc=ipwa.ne.0
      brd=dw
      if (ipwgg(1).eq.0.and.ipwgg(2).eq.0.and.ipwgg(3).eq.0) then
        ix=ictr(1)
        iy=ictr(2)
        iz=ictr(3)
        st(1)=abs(vme2(ix,iy,iz)/vme2(ix+1,iy,iz))
        st(2)=abs(vme2(ix,iy,iz)/vme2(ix-1,iy,iz))
        st(3)=abs(vme2(ix,iy,iz)/vme2(ix,iy+1,iz))
        st(4)=abs(vme2(ix,iy,iz)/vme2(ix,iy-1,iz))
        st(5)=abs(vme2(ix,iy,iz)/vme2(ix,iy,iz+1))
        st(6)=abs(vme2(ix,iy,iz)/vme2(ix,iy,iz-1))
        if (st(1).gt.1.d3.and.st(2).gt.1.d3.and.st(3).gt.1.d3.and. &
&           st(4).gt.1.d3.and.st(5).gt.1.d3.and.st(6).gt.1.d3) then
          lqsing=.true.
        else
          lqsing=.false.
        endif
      else
        lqsing=.false.
      endif

      call seqptsum(ikpt,lqsing,lx,lc,ipwa,ipwb,ngkpt,iqndx,omegap2,xkf,qq2,W, &
& npwup,nsym,iqsymndx,pwsymndx,nbcore,nbocc,ncband,nwpt,nqpt,ntpwndx, &
& wmax,vme2,ame2,falloff,isign,ebkq,indxkbnd,nkpt,eigen,bantot,invpw2ndx, &
& exch,ppcor,cor)

!      if (lc) then
!        omega=ebkq-eigen(indxkbnd(ikpt)+iband)+dw/2
!        call setetint(ebkq,qq2,vme2,W,omega,isign,lqsing,wmax, &
!& ipwa,ipwb,ngkpt,iqndx,iqsymndx,npwup, &
!& nsym,pwsymndx,invpw2ndx,nwpt,nqpt,ntpwndx, &
!& cse1)
!      endif
!write(6,*) (cse1(0)+cse1(1))/2
!write(6,*) cor(1)

    enddo
!write(6,'(i4,f12.6,4x,2f12.6)') jband,exch*27.2114,cor(iband)*27.2114
  enddo

return
end subroutine mkexch

!****************************************************************************

subroutine fndme(iband,ikpt,jband,ikqpt,igg, &
& nkpt,nkptq,npwt,npwtq,ncg,ncgq,npwarr,npwarrq,igmn,igmx, &
& kg,kgq,cg,cgq,indxkcg,indxkcgq,indxkpw,igndxq, &
& cme)
implicit none
integer :: iband,ikpt,jband,ikqpt,igg(3)
integer :: nkpt,nkptq,npwt,npwtq,ncg,ncgq
integer :: igmn(3),igmx(3)
integer :: igndxq(nkptq,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
integer :: indxkpw(nkpt),indxkcg(nkpt),indxkcgq(nkptq)
integer :: npwarr(nkpt),npwarrq(nkptq)
integer :: kg(3,npwt),kgq(3,npwtq)
double complex :: cg(ncg),cgq(ncgq)
double complex :: cme
integer :: ipw,ipw2,iwf1,iwf2,igg2(3)

!write(6,*) iband,ikpt,jband,ikqpt
  cme=(0.d0,0.d0)
  do ipw=1,npwarr(ikpt)
    iwf1=indxkcg(ikpt)+(iband-1)*npwarr(ikpt)+ipw
    igg2=kg(:,indxkpw(ikpt)+ipw)-igg
    if (igg2(1).ge.igmn(1).and.igg2(1).le.igmx(1).and. &
&       igg2(2).ge.igmn(2).and.igg2(2).le.igmx(2).and. &
&       igg2(3).ge.igmn(3).and.igg2(3).le.igmx(3)) then
      ipw2=igndxq(ikqpt,igg2(1),igg2(2),igg2(3))
      if (ipw2.ne.0) then
        iwf2=indxkcgq(ikqpt)+(jband-1)*npwarrq(ikqpt)+ipw2
        cme=cme+cg(iwf1)*conjg(cgq(iwf2))
!write(6,'(i4,2x,3i3,2x,3i3,2x,i4,2es11.4,2x,2es11.4)') ipw,kg(:,indxkpw(ikpt)+ipw),igg2,ipw2,cg(iwf1),cgq(iwf2)
      endif
    endif
!write(6,'(i4,2x,3i3,2x,3i8)') ipw,kg(:,indxkpw(ikpt)+ipw),indxkcg(ikpt),(iband-1)*npwarr(ikpt),iwf1
  enddo

return
end subroutine fndme


      integer function hepcmp(id)

C...Purpose: to compress the standard ID codes for use in mass and decay
C...arrays; also to check whether a given code actually is defined.

C      ID     = particle ID
C      hepcmp = compressed index

      integer id
      integer cmplist(2210)

      integer hepchg
      external hepchg

      data (cmplist(i), i=1,100) /
     1 1, 2, 3, 4, 5, 6, 7, 8, 9,
     2 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
     3 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
     4 30, 31, 32, 33, 34, 35, 36, 37, 38, 39,
     5 40, 41, 42, 43, 44, 45, 46, 47, 48, 49,
     6 50, 51, 52, 53, 54, 55, 56, 57, 58, 59,
     7 60, 61, 62, 63, 64, 65, 66, 67, 68, 69,
     8 70, 71, 72, 73, 74, 75, 76, 77, 78, 79,
     9 80, 81, 82, 83, 84, 85, 86, 87, 88, 89,
     * 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100/
      data (cmplist(i), i=101,110) /
     1 310, 130, 0, 0, 0, 0, 110, 990, 9990, 0/
      data (cmplist(i), i=111,170) /
     1 1000001, 1000002, 1000003, 1000004, 1000005, 1000006,
     1 1000007, 1000008, 1000009, 0,
     2 1000011, 1000012, 1000013, 1000014, 1000015, 1000016,
     2 1000017, 1000018, 1000019, 0,
     3 1000021, 1000022, 1000023, 1000024, 1000025, 1000026,
     3 1000027, 1000028, 1000029, 0,
     4 1000031, 1000032, 1000033, 1000034, 1000035, 1000036,
     4 1000037, 1000038, 1000039, 0,
     5 1000041, 1000042, 1000043, 1000044, 1000045, 1000046,
     5 1000047, 1000048, 1000049, 0,
     6 1000051, 1000052, 1000053, 1000054, 1000055, 1000056,
     6 1000057, 1000058, 1000059, 0/
      data (cmplist(i), i=171,190) /
     1 2000001, 2000002, 2000003, 2000004, 2000005, 2000006,
     1 2000007, 2000008, 2000009, 0,
     2 2000011, 2000012, 2000013, 2000014, 2000015, 2000016,
     2 2000017, 2000018, 2000019, 0/
      data (cmplist(i), i=191,210) /
     1 3000111, 3000211, 3000221, 3000113, 3000213, 3100221,
     1 3000223, 0, 0, 0,
     2 3100021, 3060111, 3160111, 3130113, 3140113, 3150113,
     2 3160113, 0, 0, 0/
      data (cmplist(i), i=211,230) /
     1 4000001, 4000002, 4000003, 4000004, 4000005, 4000006,
     1 4000007, 4000008, 4000009, 0,
     2 4000011, 4000012, 4000013, 4000014, 4000015, 4000016,
     2 4000017, 4000018, 4000019, 4000039/
      data (cmplist(i), i=231,240) /
     1 9900061, 9900062, 9900024, 9900012, 9900014, 9900016,
     1 9900023, 9221132, 9331122, 0/
      data (cmplist(i), i=241,260) /
     1 9910113, 9910211, 9910223, 9910333, 9910443, 9912112,
     1 9912212, 0, 0, 0,
     2 9920022, 9922212, 10022, 20022, 0, 0, 0, 0, 0, 0/
      data (cmplist(i), i=261,2200) / 1940*0/
      data (cmplist(i), i=2201,2210) /
     1 1001001002, 1002001002, 1003001002, 1003002001, 1004002001,
     1 5*0/

      save cmplist

C...Subdivide standard ID code into constituent pieces.
      hepcmp=0
      kqa=iabs(id)
      kqn=mod(kqa/1000000000,10)
      kqna=mod(kqa/1000000,1000)
      kqnz=mod(kqa/1000,1000)
      kqx=mod(kqa/1000000,10)
      kqr=mod(kqa/100000,10)
      kql=mod(kqa/10000,10)
      kq3=mod(kqa/1000,10)
      kq2=mod(kqa/100,10)
      kq1=mod(kqa/10,10)
      kqj=mod(kqa,10)
      kshort=mod(kqa,100)
      kqsm=(kqj-1)/2
      irt = mod(kqa,10000)
      k99=mod(kqa/100000,100)
      is = kqsm
      if(kqx.eq.9) is = kqsm + 5

      if(kqa.eq.0)  then
      elseif(kqa.ge.10000000) then
C... ions
	do i=2201,2210
            if(cmplist(i).eq.kqa) hepcmp = i
	enddo
        if(id.lt.0) hepcmp=0
      elseif(kqa.le.100) then
C... need to check antiparticle legality
        hepcmp=kqa
        ich=hepchg(id)
        if(id.lt.0.and.ich.eq.0)then
          if(kqa.ge.1.and.kqa.le.8)then
C... quarks
          elseif(kqa.ge.11.and.kqa.le.18)then
C... leptons
          elseif(kqa.eq.41 .or. kqa.eq.42)then
C... R0 or LQ
          elseif(kqa.ge.81)then
C... internal definitions
          else
            hepcmp=0
          endif
        endif
      elseif(kqj.eq.0) then
	do i=101,110
            if(cmplist(i).eq.kqa) hepcmp = i
	enddo
        if(id.lt.0) hepcmp=0
      elseif(kshort.eq.22 .and. kql.gt.0 .and. kq2.eq.0) then
C virtual gamma and Cerenkov
	do i=241,260
            if(cmplist(i).eq.kqa) hepcmp = i
	enddo
        if(id.lt.0) hepcmp=0
      elseif(kqx.eq.1 .or. kqx.eq.2)then
C...SUSY
	do i=111,190
            if(cmplist(i).eq.kqa) hepcmp = i
	enddo
        ich=hepchg(id)
        if(id.lt.0.and.ich.eq.0)then
          if(irt.ge.1.and.irt.le.8)then
C... quarks
          elseif(irt.ge.11.and.irt.le.18)then
C... leptons
          else
            hepcmp=0
          endif
        endif
      elseif(kqx.ge.3 .and. kqx.le.4)then
	do i=191,240
            if(cmplist(i).eq.kqa) hepcmp = i
	enddo
        if(kq3.eq.0 .and. id.lt.0) then
          if(kq1.gt.0 .and. kq2.eq.kq1) hepcmp=0
	endif
      elseif(k99.eq.99)then
	do i=231,260
            if(cmplist(i).eq.kqa) hepcmp = i
	enddo
        if(kq3.eq.0 .and. id.lt.0) then
          if(kq1.gt.0 .and. kq2.eq.kq1) hepcmp=0
	endif
	if(id.lt.0 .and. kshort.eq.22)  hepcmp=0
      elseif(kqx.eq.9 .and. kqr.ge.1)then
C...possible pentaquark
	do i=231,240
            if(cmplist(i).eq.kqa) hepcmp = i
	enddo
      elseif(kqx.gt.4 .and. kqx.lt.9)then
C...undefined

      elseif(kq1.eq.0) then
C...Diquarks.
C... 103
        if(kqx.ne.0 .and. kqr.ne.0 .and. kql.ne.0)then
C... no excited states
        elseif(kqj.ne.1.and.kqj.ne.3) then
C... only 2 spin states
        elseif(kq3.eq.0.or.kq3.eq.9.or.kq2.eq.0.or.kq2.eq.9) then
C... illegal (no gluons allowed)
        elseif(kq3.lt.kq2) then
C... illegal quark order
        elseif(kq3.eq.kq2 .and. kqj.eq.1) then
C... illegal spin
        else
C... all diquarks are the same...
          hepcmp=103
        endif

      elseif(kq3.eq.0) then
C...Mesons.
C... 260 - ...
        if(kq2.eq.0.or.kq2.eq.9.or.kq1.eq.0.or.kq1.eq.9) then
C... illegal (no gluons allowed)
        elseif(kq2.lt.kq1) then
C... illegal quark order
        elseif(id.lt.0.and.(kq2.eq.kq1)) then
C... illegal antiparticle
        elseif(mod(kqj,2).eq.0)then
C... illegal spin
        elseif(kq2.le.2 .and. kq1.eq.1) then
C... 260 - 559 [ kqr = 0,1,2  kql = 0-4 ]
	  hepcmp = 260 + (kq2-1)*150 + kqr*50 + kql*10 + is
	  if(kql.gt.4 .or. kqr.gt.2) hepcmp = 0
	elseif(kq2.eq.2 .and. kq1.eq.2) then
C... 560 - 799 [ kqr = 0,1,2  kql = 0-9 ]
	  hepcmp = 560 + kqr*100 + kql*10 + is
	  if(kqr.gt.2) hepcmp = 0
	elseif(kq2.eq.3 .and. kq1.eq.3) then
C... 800 - 859 [ kqr = 0,1  kql = 0-2 ]
	  hepcmp = 860 + kqr*30 + kql*10 + is
	  if(kql.gt.2 .or. kqr.gt.1) hepcmp = 0
	elseif(kq2.eq.3 .and. kq1.le.2) then
C... 860 - 1099 [ kqr = 0,1,2  kql = 0-3 ]
	  hepcmp = 920 + (kq1-1)*120 + kqr*40 + kql*10 + is
	  if(kql.gt.3 .or. kqr.gt.2) hepcmp = 0
	elseif(kq2.eq.4 .and. kq1.le.3) then
C... 1100 - 1189 [ kqr = 0  kql = 0-2 ]
	  hepcmp = 1160 + kqr*90 + (kq1-1)*30 + kql*10 + is
cc	  if(kql.gt.2 .or. kqr.gt.0 .or. kqx.gt.0) hepcmp = 0
	  if(kql.gt.2 .or. kqr.gt.2 .or. kqx.gt.0) hepcmp = 0
	elseif(kq2.eq.4 .and. kq1.eq.4) then
C... 1190 - 1269 [ kqr = 0,1  kql = 0-3 ]
	  hepcmp = 1430 + kqr*40 + kql*10 + is
	  if(kql.gt.3 .or. kqr.gt.1) hepcmp = 0
	elseif(kq2.eq.5 .and. kq1.le.4) then
C... 1270 - 1389 [ kqr = 0  kql = 0-2 ]
	  hepcmp = 1510 + (kq1-1)*30 + kql*10 + is
	  if(kql.gt.2 .or. kqr.gt.0 .or. kqx.gt.0) hepcmp = 0
	elseif(kq2.eq.5 .and. kq1.eq.5) then
C... 1390 - 1549 [ kqr = 0,1,2,3  kql = 0-3 ]
	  hepcmp = 1630 + kqr*40 + kql*10 + is
	  if(kql.gt.3 .or. kqr.gt.3) hepcmp = 0
        elseif(kq2.eq.6)then
C... 1550 - 1609 [ kqr = 0  kql = 0 ]
	  hepcmp = 1790 + (kq1-1)*10 + is
	  if(kql.gt.0 .or. kqr.gt.0 .or. kqx.gt.0) hepcmp = 0
        elseif(kq2.eq.7)then
C... 1610 - 1679 [ kqr = 0  kql = 0 ]
	  hepcmp = 1850 + (kq1-1)*10 + is
	  if(kql.gt.0 .or. kqr.gt.0 .or. kqx.gt.0) hepcmp = 0
        elseif(kq2.eq.8)then
C... 1680 - 1759 [ kqr = 0  kql = 0 ]
	  hepcmp = 1920 + (kq1-1)*10 + is
	  if(kql.gt.0 .or. kqr.gt.0 .or. kqx.gt.0) hepcmp = 0
        endif

      elseif(kqx.eq.0.and.(kqj.eq.2.or.kqj.eq.4)) then
C...Baryons.
C... no excited states and only spins 1/2 and 3/2
        if(kq3.eq.0.or.kq3.eq.9.or.kq2.eq.0.or.kq2.eq.9.or.
     1        kq1.eq.0.or.kq1.eq.9) then
C... illegal (no gluons allowed)
        elseif(kq3.lt.kq1.or.kq3.lt.kq2) then
C... illegal quark order
        elseif(kq3.ge.7) then
C... l and h baryons are all the same
C... 104, 105
          hepcmp=97+kq3
          if(kq3.eq.kq1.and.kq3.eq.kq2.and.kqj.eq.2) hepcmp=0
          if(kq2.lt.kq1 .and. kq3.eq.kq1) hepcmp=0
          if(kq2.lt.kq1 .and. kqj.eq.4) hepcmp=0
          if(kq3.gt.8) hepcmp=0
        elseif(kqj.eq.2) then
C...Spin 1/2 baryons.
          if(kq3.eq.kq1 .and. kq3.eq.kq2)then
          elseif(kq2.lt.kq1 .and. kq3.eq.kq1)then
          elseif(kq2.lt.kq1) then
C...antisymmtric (Lambda, etc.)
C... 1760 - 1780
            hepcmp=2000+((kq3-1)*(kq3-2)*(kq3-3))/6+
     1                  ((kq1-1)*(kq1-2))/2+kq2
          else
C...symmtric
C... 1780 - 1791
            hepcmp=2020+((kq3+1)*kq3*(kq3-1))/6+(kq2*(kq2-1))/2+kq1
          endif
        elseif(kqj.eq.4) then
C...Spin 3/2 baryons.
          if(kq2.lt.kq1 .and. kq3.eq.kq1)then
          elseif(kq2.lt.kq1) then
C...no excited states for antisymmetric baryons
          else
C...symmetric
C... 1840 - 1896
            hepcmp=2080+((kq3+1)*kq3*(kq3-1))/6+(kq2*(kq2-1))/2+kq1
          endif
        endif

      endif

      return
      end


! 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

!> test of rttov interfaces

program rttov_test

use         types_mod, only : r8

use     utilities_mod, only : register_module, initialize_utilities, &
                              error_handler, E_ERR, E_MSG, &
                              finalize_utilities

use      location_mod, only : location_type

use      obs_kind_mod, only : get_index_for_type_of_obs

! The obs_def_rttov_mod.f90 has a bunch of includes for the RTTOV modules.

use obs_def_rttov_mod, only : atmos_profile_type, &
                              trace_gas_profile_type, &
                              cloud_profile_type, &
                              aerosol_profile_type, &
                              rttov_sensor_type, &
                              visir_metadata_type, &
                              mw_metadata_type, &
                              get_rttov_sensor, &
                              sensor_runtime_setup, &
                              do_forward_model, &
                              read_sensor_db_file, &
                              atmos_profile_setup, &
                              trace_gas_profile_setup, &
                              aerosol_profile_setup, &
                              cloud_profile_setup

use       rttov_types, only : rttov_options, rttov_options_scatt

   implicit none

   integer, parameter :: ens_size  = 3
   integer, parameter :: numlevels = 54

   type(location_type)          :: location
   type(atmos_profile_type)     :: atmos
   type(trace_gas_profile_type) :: trace_gas
   type(cloud_profile_type)     :: clouds
   type(aerosol_profile_type)   :: aerosols

   integer, parameter :: test_ir_plat_id   = 9
   integer, parameter :: test_ir_sat_id    = 2
   integer, parameter :: test_ir_sensor_id = 11

   integer, parameter :: test_mw_plat_id   = 9
   integer, parameter :: test_mw_sat_id    = 2
   integer, parameter :: test_mw_sensor_id = 3

   integer :: test_ir_instrument(3)
   integer :: test_mw_instrument(3)
   integer :: sensor_instrument(3)

   character(len=512) :: rttov_sensor_db_file = 'rttov_test_me.csv'
   type(rttov_sensor_type), pointer :: sensor_ir
   type(rttov_sensor_type), pointer :: sensor_mw

   logical :: use_q2m              = .true.
   logical :: use_uv10m            = .true.
   logical :: use_wfetch           = .true.
   logical :: use_water_type       = .true.
   logical :: use_salinity         = .true.
   logical :: supply_foam_fraction = .true.
   logical :: use_sfc_snow_frac    = .true.

   logical :: ozone_data  = .false.
   logical :: co2_data    = .false.
   logical :: n2o_data    = .false.
   logical :: ch4_data    = .false.
   logical :: co_data     = .false.
   logical :: so2_data    = .false.

   logical :: add_aerosl  = .false.
   integer :: aerosl_type = 1  ! OPAC
   integer :: flavor

   logical :: cfrac_data          = .true.
   logical :: clw_data            = .true.
   integer :: clw_scheme          = 1
   logical :: rain_data           = .false.
   logical :: ciw_data            = .true.
   integer :: ice_scheme          = 1
   integer :: idg_scheme          = 1
   logical :: use_icede           = .false.
   logical :: snow_data           = .false.
   logical :: graupel_data        = .false.
   logical :: hail_data           = .false.
   logical :: w_data              = .false.
   logical :: htfrtc_simple_cloud = .false.

   logical :: first_lvl_is_sfc  = .false.
   logical :: mw_clear_sky_only = .false.
   logical :: do_lambertian     = .false.
   logical :: use_totalice      = .false.
   logical :: use_zeeman        = .false.

   real(r8) :: radiances(ens_size)
   integer  :: error_status(ens_size)

   type(visir_metadata_type), pointer :: visir_mds(:)
   type(mw_metadata_type),    pointer :: mw_mds(:)
   type(visir_metadata_type), pointer :: visir_md
   type(mw_metadata_type),    pointer :: mw_md

   ! Profiles of t, q, p, and clw from RTTOV
   ! Original location: rttov_test/profile-datasets/standard54lev_clw/{001 - 003}

   ! K
   real(r8), parameter :: t_data(*) = (/ &
         178.1742, 166.1031, 200.9644, &
         188.2529, 176.2058, 213.3252, &
         205.1321, 196.4627, 224.7168, &
         221.334,  217.0163, 235.2652, &
         237.077,  237.2116, 245.0305, &
         252.3965, 253.1156, 253.9712, &
         261.5169, 264.7174, 261.5057, &
         267.6492, 272.1215, 265.6042, &
         269.7398, 275.4912, 262.2031, &
         263.9926, 270.8047, 252.5451, &
         257.2797, 262.9886, 243.4565, &
         251.061,  255.8046, 235.2337, &
         245.3975, 249.3036, 227.8755, &
         240.2603, 243.4317, 221.3266, &
         235.5384, 238.1507, 218.3437, &
         231.2017, 233.7377, 216.5764, &
         227.2464, 229.8147, 215.4607, &
         223.4022, 226.9817, 215.2631, &
         219.8331, 224.819,  215.2,    &
         216.4919, 223.0744, 215.2,    &
         212.2492, 221.3649, 215.2,    &
         207.1632, 219.7497, 215.2,    &
         202.3874, 218.143,  215.4279, &
         198.0815, 216.785,  216.0201, &
         195.2696, 215.7,    216.5855, &
         198.3492, 215.7,    217.1217, &
         204.5386, 215.7,    217.6306, &
         210.5458, 215.716,  218.1151, &
         216.794,  216.2984, 218.577,  &
         222.5243, 222.0199, 219.0153, &
         228.1523, 227.5903, 219.4315, &
         233.7824, 233.0306, 221.2409, &
         239.2519, 238.2408, 225.7942, &
         244.4527, 243.2519, 230.2292, &
         249.4698, 248.1434, 234.4881, &
         254.3639, 252.8513, 238.5656, &
         259.0342, 257.3262, 242.4896, &
         263.4607, 261.5477, 246.2457, &
         267.7589, 265.3643, 249.8067, &
         271.8353, 268.9933, 253.2246, &
         275.7137, 272.4373, 256.4401, &
         279.3804, 275.7036, 259.4958, &
         282.8149, 278.7564, 262.0787, &
         285.1086, 281.6015, 263.6424, &
         286.9082, 284.2282, 265.0843, &
         289.0168, 286.3178, 266.4233, &
         291.3232, 288.0253, 267.6449, &
         293.4089, 289.5693, 268.7503, &
         295.3068, 290.968,  269.7518, &
         296.9916, 292.2075, 270.6383, &
         298.4603, 293.288,  271.4111, &
         299.7152, 294.2112, 272.0715, &
         300.7582, 294.9785, 272.6202, &
         301.5907, 295.591,  273.0583/)

   ! moisture MR (g/kg)
   real(r8), parameter :: q_data(*) = (/ &
        0.000878,  0.000881,  0.000874, &
        0.001458,  0.001357,  0.001380, &
        0.002198,  0.001843,  0.001836, &
        0.002879,  0.002278,  0.002247, &
        0.003382,  0.002680,  0.002618, &
        0.003716,  0.003022,  0.002869, &
        0.003732,  0.003246,  0.003028, &
        0.003732,  0.003369,  0.003078, &
        0.003684,  0.003421,  0.003110, &
        0.003527,  0.003395,  0.003110, &
        0.003348,  0.003282,  0.003080, &
        0.003135,  0.003155,  0.003047, &
        0.002940,  0.003100,  0.003016, &
        0.002763,  0.003061,  0.002989, &
        0.002600,  0.003002,  0.002964, &
        0.002436,  0.002924,  0.002941, &
        0.002251,  0.002808,  0.002919, &
        0.002099,  0.002700,  0.002899, &
        0.001999,  0.002583,  0.002860, &
        0.001791,  0.002418,  0.002824, &
        0.001685,  0.002221,  0.002801, &
        0.001621,  0.002095,  0.002799, &
        0.001625,  0.002002,  0.002799, &
        0.001727,  0.001960,  0.002799, &
        0.001817,  0.001999,  0.002847, &
        0.001991,  0.002066,  0.002914, &
        0.002663,  0.002338,  0.002977, &
        0.003953,  0.003408,  0.003089, &
        0.006087,  0.005998,  0.003579, &
        0.016127,  0.017736,  0.005300, &
        0.037237,  0.051778,  0.011865, &
        0.084644,  0.120799,  0.022572, &
        0.165268,  0.201043,  0.035125, &
        0.282768,  0.291349,  0.059046, &
        0.447403,  0.400520,  0.102923, &
        0.672443,  0.567801,  0.169275, &
        0.955907,  0.756625,  0.282357, &
        1.293410,  0.963454,  0.399943, &
        1.782302,  1.245328,  0.517178, &
        2.229163,  1.674571,  0.678396, &
        2.620337,  2.237942,  0.856932, &
        3.659562,  2.921221,  1.112063, &
        4.967239,  3.601064,  1.342873, &
        6.751134,  4.607604,  1.536489, &
        8.590907,  5.597516,  1.714924, &
        9.945896,  6.583699,  1.873173, &
       10.905132,  7.529462,  2.016856, &
       11.769977,  8.382210,  2.148540, &
       12.920812,  9.302317,  2.300865, &
       13.997381, 10.129011,  2.435632, &
       14.932796, 10.847873,  2.553067, &
       15.729741, 11.460740,  2.653370, &
       16.390504, 11.969164,  2.736708, &
       16.916947, 12.374422,  2.803219/)

   ! hPa
   real(r8), parameter :: p_data(*) = (/ &
         0.005,    0.005,    0.005,    &
         0.0131,   0.0131,   0.0131,   &
         0.0304,   0.0304,   0.0304,   &
         0.0644,   0.0644,   0.0644,   &
         0.1263,   0.1263,   0.1263,   &
         0.2324,   0.2324,   0.2324,   &
         0.4052,   0.4052,   0.4052,   &
         0.6749,   0.6749,   0.6749,   &
         1.0801,   1.0801,   1.0801,   &
         1.6691,   1.6691,   1.6691,   &
         2.5011,   2.5011,   2.5011,   &
         3.6462,   3.6462,   3.6462,   &
         5.1864,   5.1864,   5.1864,   &
         7.215,    7.215,    7.215,    &
         9.8368,   9.8368,   9.8368,   &
         13.1672,  13.1672,  13.1672,  &
         17.3308,  17.3308,  17.3308,  &
         22.4601,  22.4601,  22.4601,  &
         28.6937,  28.6937,  28.6937,  &
         36.1735,  36.1735,  36.1735,  &
         45.043,   45.043,   45.043,   &
         55.4433,  55.4433,  55.4433,  &
         67.5109,  67.5109,  67.5109,  &
         81.3744,  81.3744,  81.3744,  &
         97.1505,  97.1505,  97.1505,  &
         114.9415, 114.9415, 114.9415, &
         134.8318, 134.8318, 134.8318, &
         156.8846, 156.8846, 156.8846, &
         181.1394, 181.1394, 181.1394, &
         207.6092, 207.6092, 207.6092, &
         236.2784, 236.2784, 236.2784, &
         267.1012, 267.1012, 267.1012, &
         300.,     300.,     300.,      &
         334.8648, 334.8648, 334.8648, &
         371.5529, 371.5529, 371.5529, &
         409.8893, 409.8893, 409.8893, &
         449.6677, 449.6677, 449.6677, &
         490.6516, 490.6516, 490.6516, &
         532.5769, 532.5769, 532.5769, &
         575.1538, 575.1538, 575.1538, &
         618.0706, 618.0706, 618.0706, &
         660.9965, 660.9965, 660.9965, &
         703.5863, 703.5863, 703.5863, &
         745.4841, 745.4841, 745.4841, &
         786.3278, 786.3278, 786.3278, &
         825.7546, 825.7546, 825.7546, &
         863.4047, 863.4047, 863.4047, &
         898.9275, 898.9275, 898.9275, &
         931.9853, 931.9853, 931.9853, &
         962.2587, 962.2587, 962.2587, &
         989.451,  989.451,  989.451,  &
         1013.292, 1013.292, 1013.292, &
         1033.544, 1033.544, 1033.544, &
         1050.,    1050.,    1050./)

   ! cloud liquid water (kg/kg)
   real(r8), parameter :: clw_prof_data(*) = (/ &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         6.02780E-05, 1.95948E-05, 8.94624E-05, &
         1.00000E-04, 1.00000E-04, 7.95915E-05, &
         0.00000E+00, 1.86917E-05, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 7.54063E-05, &
         0.00000E+00, 0.00000E+00, 3.69476E-05, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 1.77796E-06, &
         2.29149E-05, 2.98885E-05, 5.87432E-05, &
         8.08015E-05, 8.72882E-05, 1.00000E-04, &
         1.00000E-04, 1.41726E-04, 1.00000E-04, &
         1.00000E-04, 1.92606E-04, 1.00000E-04, &
         1.00000E-04, 1.19949E-04, 1.00000E-04, &
         1.00000E-04, 3.23937E-05, 1.00000E-04, &
         7.80533E-05, 0.00000E+00, 6.50497E-05, &
         3.96129E-05, 0.00000E+00, 3.01453E-05, &
         4.85138E-06, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00, &
         0.00000E+00, 0.00000E+00, 0.00000E+00 /)

   real(r8), parameter :: cfrac_prof_data(*) = (/ &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0, &
         1.0d0, 1.0d0, 1.0d0/)

   integer, parameter :: surftype_data(*)  = (/ &
      1, 1, 1/)
   integer, parameter :: watertype_data(*) = (/ &
      0, 1, 1/)

   real(r8), parameter :: sfc_t_data(*) = (/ &
      300.2, 294.8, 272.2/)

   real(r8), parameter :: salinity_data(*) = (/ &
      35.0, 33.0, 37.0/)

   real(r8), parameter :: foam_fraction_data(*) = (/ &
      0.0, 0.3, 1.0/)

   real(r8), parameter :: snow_fraction_data(*) = (/ &
      0.0, 0.0, 0.0/)

   real(r8), parameter :: specularity_data(*) = (/ &
      0.0, 0.3, 1.0/)

   real(r8), parameter :: fastem_data(*) = (/ &
      3.0,  3.0,  3.0, &
      5.0,  5.0,  5.0, &
     15.0, 15.0, 15.0, &
      0.1,  0.1,  0.1, &
      0.3,  0.3,  0.3/)

   real(r8), parameter :: s2m_t_data(*) = (/ &
    298.7, 295.2,  272.2 /)

   ! 2m moisture MR (g/kg)
   real(r8), parameter :: s2m_q_data(*) = (/ &
    15.128594151295280, 11.453320846477883, 2.7345502236699266/)

   real(r8), parameter :: sfc_p_data(*) = (/ &
   1077.0,  1063.0,  1100.0 /)

   real(r8), parameter :: s10m_u_data(*) = (/ &
      5.0,  0.0,  -3.0 /)
   real(r8), parameter :: s10m_v_data(*) = (/ &
      2.0,  7.0,  -1.0 /)

   real(r8), parameter :: wfetch_data(*) = (/ &
      100000.0, 50000.0, 200000.0 /)

   real(r8), parameter :: zenangle_data(*) = (/ &
      45.0, 50.0, 45.0 /)

   real(r8), parameter :: azangle_data(*) = (/ &
      0.0, 185.0, 170.0 /)

   real(r8), parameter :: sunzenangle_data(*) = (/ &
      45.0, 185.0, 35.0/)

   real(r8), parameter :: sunazangle_data(*) = (/ &
      179.0, 179.0, 179.0/)

   real(r8), parameter :: lat_data(*) = (/ &
      15.0, 45.0, 45.0/)

   real(r8), parameter :: lon_data(*) = (/ &
      300.0, 270.0, 180.0/)

   real(r8), parameter :: elev_data(*) = (/ &
      0.0, 0.0, 0.0/)

   real(r8), parameter :: mag_field_data(*) = (/ &
      0.2, 0.5, 0.7/)

   real(r8), parameter :: cosbk_data(*) = (/ &
      0.0, 0.0, 0.5/)

   integer :: channel
   integer :: i, j, ind1d

   type(rttov_options),       pointer :: opts        => null() ! Options for RTTOV-DIRECT
   type(rttov_options_scatt), pointer :: opts_scatt  => null() ! Options for RTTOV-SCATT

   ! version controlled file description for error handling, do not edit
   character(len=*), parameter :: source   = 'rttov_test.f90'
   character(len=*), parameter :: revision = ''
   character(len=*), parameter :: revdate  = ''

   character(len=512) :: string1, string2, string3

   call initialize_utilities('rttov_test')
   call register_module(source,revision,revdate)

   allocate(visir_mds(3))
   allocate(mw_mds(3))

   ! setup: create a dummy rttov_sensor_db file
   open(unit=142, file=rttov_sensor_db_file)

   write(142,'(A)')'<DART Obs Type>,<Platform ID>,<Satellite ID>,<Sensor ID>,' // &
      '<Sensor type>,<Coef file name>,<Channels to use list (optional)>'
   write(142,'(A,I0,A,I0,A,I0,A)')'EOS_2_AMSUA_TB,',test_mw_plat_id,',',test_mw_sat_id,',',&
      test_mw_sensor_id,',mw,rtcoef_eos_2_amsua.dat'
   write(142,'(A,I0,A,I0,A,I0,A)')'EOS_2_AIRS_RADIANCE,',test_ir_plat_id,',',test_ir_sat_id,',',&
      test_ir_sensor_id,',ir,rtcoef_eos_2_airs.H5,168,900'

   close(142)

   ! test 1: reading of newly created sensor file
   call read_sensor_db_file(rttov_sensor_db_file)

   ! test 2.1: check that the IR instrument id matches what is expected
   test_ir_instrument(1) = test_ir_plat_id
   test_ir_instrument(2) = test_ir_sat_id
   test_ir_instrument(3) = test_ir_sensor_id

   sensor_ir => get_rttov_sensor(test_ir_instrument)

   sensor_instrument(1) = sensor_ir % platform_id
   sensor_instrument(2) = sensor_ir % satellite_id
   sensor_instrument(3) = sensor_ir % sensor_id

   if (any(sensor_instrument /= test_ir_instrument)) then
      write(string1,*) 'ERROR: returned sensor_instrument (IR) ',sensor_instrument,&
         ' differed from expected:',test_ir_instrument
      call error_handler(E_ERR,'rttov_test',string1,&
         source, revision, revdate)
   end if

   if (size(sensor_ir % channels) /= 2) then
      write(string1,*) 'ERROR: returned sensor_instrument (IR) ',sensor_instrument,&
         ' channel size ',size(sensor_ir % channels),'differed from expected:',2

      call error_handler(E_ERR,'rttov_test',string1,&
         source, revision, revdate)
   end if

   ! test 2.2: check that the MW instrument id matches what is expected
   test_mw_instrument(1) = test_mw_plat_id
   test_mw_instrument(2) = test_mw_sat_id
   test_mw_instrument(3) = test_mw_sensor_id

   sensor_mw => get_rttov_sensor(test_mw_instrument)

   sensor_instrument(1) = sensor_mw % platform_id
   sensor_instrument(2) = sensor_mw % satellite_id
   sensor_instrument(3) = sensor_mw % sensor_id

   if (any(sensor_instrument /= test_mw_instrument)) then
      write(string1,*) 'ERROR: returned sensor_instrument (MW) ',sensor_instrument,&
         ' differed from expected:',test_mw_instrument

      call error_handler(E_ERR,'rttov_test',string1,&
         source, revision, revdate)
   end if

   ! test 3: exercise the IR forward (direct) operator

   ! test 3.1: setup atmos, trace gas, aerosols, and clouds
   call atmos_profile_setup(atmos, ens_size, numlevels, use_q2m, &
      use_uv10m, use_wfetch, use_water_type, use_salinity,       &
      supply_foam_fraction, use_sfc_snow_frac)

   call trace_gas_profile_setup(trace_gas, ens_size, numlevels,  &
      ozone_data, co2_data, n2o_data, ch4_data, co_data, so2_data)

   if (add_aerosl) then
      call aerosol_profile_setup(aerosols, ens_size, numlevels,  &
         aerosl_type)
   end if

   call cloud_profile_setup(clouds, ens_size, numlevels,     &
      cfrac_data, clw_data, clw_scheme, rain_data, ciw_data, &
      ice_scheme, use_icede, snow_data, graupel_data,        &
      hail_data, w_data, htfrtc_simple_cloud)

   ! test 3.2: fill in the profiles for the IR values
   do j=1,numlevels
      do i=1,ens_size
         ind1d = (j-1)*ens_size+i
         atmos%temperature(i,j) = t_data(ind1d)
         atmos%moisture(i,j)    = q_data(ind1d)/1000.d0
         atmos%pressure(i,j)    = 100.d0*p_data(ind1d) ! hPa -> Pa
         clouds%clw(i,j)        = clw_prof_data(ind1d)
         clouds%cfrac(i,j)      = cfrac_prof_data(ind1d)
      end do
   end do

   do i=1,ens_size
      atmos%surftype(i)      = surftype_data(i)
      atmos%water_type(i)    = watertype_data(i)
      atmos%skin_temp(i)     = sfc_t_data(i)
      atmos%sfc_salinity(i)  = salinity_data(i)
      atmos%sfc_foam_frac(i) = foam_fraction_data(i)
      atmos%sfc_snow_frac(i) = snow_fraction_data(i)
      atmos%s2m_t(i)         = s2m_t_data(i)
      atmos%s2m_q(i)         = s2m_q_data(i)/1000.d0
      atmos%sfc_p(i)         = 100.d0*sfc_p_data(i)  ! hPa -> Pa
      atmos%s10m_u(i)        = s10m_u_data(i)
      atmos%s10m_v(i)        = s10m_v_data(i)
      atmos%wfetch(i)        = wfetch_data(i)
      atmos%sfc_elev(i)      = elev_data(i)
   end do

   do i=1,ens_size
      visir_mds(i)%sat_az      = azangle_data(i)
      visir_mds(i)%sat_ze      = zenangle_data(i)
      visir_mds(i)%sun_az      = sunazangle_data(i)
      visir_mds(i)%sun_ze      = sunzenangle_data(i)
      visir_mds(i)%platform_id = sensor_ir % platform_id
      visir_mds(i)%sat_id      = sensor_ir % satellite_id
      visir_mds(i)%sensor_id   = sensor_ir % sensor_id
      visir_mds(i)%specularity = specularity_data(i)
   end do

   ! test 3.3: specify IR options
   allocate(opts)

   ! these options have descriptions above, except for where defaults are set outside of user-control
   opts % interpolation % addinterp        = .true.      ! Allow interpolation of input profile
   opts % interpolation % reg_limit_extrap = .true.      ! Extrapolate beyond top of model intelligently
   opts % interpolation % interp_mode      = 1
   opts % interpolation % lgradp           = .false.     ! Do not allow TL/AD/K of user pressure levels
   opts % interpolation % spacetop         = .true.      ! Treat model top as space boundary (not recommended to be false)

   opts % config % do_checkinput    = .true.
   opts % config % apply_reg_limits = .true.
   opts % config % verbose          = .true.
   opts % config % fix_hgpl         = .false.

   opts % rt_all % switchrad              = .false.                 ! switch to BT for AD/K if microwave
   opts % rt_all % do_lambertian          = do_lambertian
   opts % rt_all % lambertian_fixed_angle = .true.
   opts % rt_all % rad_down_lin_tau       = .false.
   opts % rt_all % use_q2m                = use_q2m
   opts % rt_all % addrefrac              = .false.
   opts % rt_all % plane_parallel         = .false.

   ! test 3.4: setup the IR sensor runtime
   call sensor_runtime_setup(sensor_ir,             &
                             ens_size=ens_size,     &
                             nlevs=numlevels,       &
                             opts=opts)

   visir_md => visir_mds(1)
   mw_md    => null()
   channel = 168

   flavor = get_index_for_type_of_obs('MSG_4_SEVIRI_RADIANCE')

   ! test 3.5: call the IR forward operator
   call do_forward_model(ens_size, numlevels, flavor, location, &
      atmos, trace_gas, clouds, aerosols, sensor_ir, channel, &
      first_lvl_is_sfc, mw_clear_sky_only, clw_scheme,        &
      ice_scheme, idg_scheme, aerosl_type, do_lambertian,     &
      use_totalice, use_zeeman, radiances, error_status,      &
      visir_md=visir_md, mw_md=mw_md)

   write(string1,*) 'radiances:',radiances

   call error_handler(E_MSG,'rttov_test',string1,&
      source, revision, revdate)

   ! test 4: exercise the MW scatt forward operator

   ! test 4.1: fill in the profiles for the MW values
   do i=1,ens_size
      ind1d = 0
      mw_mds(i)%fastem_p1 = fastem_data(ind1d+i)
      ind1d = 3
      mw_mds(i)%fastem_p2 = fastem_data(ind1d+i)
      ind1d = 6
      mw_mds(i)%fastem_p3 = fastem_data(ind1d+i)
      ind1d = 9
      mw_mds(i)%fastem_p4 = fastem_data(ind1d+i)
      ind1d = 12
      mw_mds(i)%fastem_p5 = fastem_data(ind1d+i)

      mw_mds(i)%sat_az      = azangle_data(i)
      mw_mds(i)%sat_ze      = zenangle_data(i)
      mw_mds(i)%platform_id = sensor_mw % platform_id
      mw_mds(i)%sat_id      = sensor_mw % satellite_id
      mw_mds(i)%sensor_id   = sensor_mw % sensor_id

      mw_mds(i)%mag_field = mag_field_data(i)
      mw_mds(i)%cosbk     = cosbk_data(i)
   end do

   ! test 4.2: set the opts_scatt properties
   opts % rt_all % switchrad            = .true.                  ! switch to BT for AD/K if microwave
   opts % rt_mw % apply_band_correction = .true.
   opts % rt_mw % clw_data              = .false.
   opts % rt_mw % clw_calc_on_coef_lev  = .false.                 ! calculate CLW optical depths on input levels
   opts % rt_mw % clw_scheme            = clw_scheme
   opts % rt_mw % clw_cloud_top         = 322.d0 ! hPa
   opts % rt_mw % fastem_version        = 6
   opts % rt_mw % supply_foam_fraction  = supply_foam_fraction

   allocate(opts_scatt)
   opts_scatt % config % do_checkinput    = .true.
   opts_scatt % config % apply_reg_limits = .true.
   opts_scatt % config % verbose          = .true.
   opts_scatt % config % fix_hgpl         = .false.

   opts_scatt % rad_down_lin_tau      = .false.
   opts_scatt % apply_band_correction = .true.
   opts_scatt % interp_mode           = 1
   opts_scatt % lgradp                = .false.               ! Do not allow TL/AD/K of user pressure levels
   opts_scatt % reg_limit_extrap      = .true.                ! intelligently extend beyond the model top
   opts_scatt % fastem_version        = 6
   opts_scatt % supply_foam_fraction  = supply_foam_fraction
   opts_scatt % use_q2m               = use_q2m
   opts_scatt % lradiance             = .false.               ! Calculate Brightness Temperatures
   opts_scatt % lusercfrac            = .false.               ! Have RTTOV-SCATT calculate the effective cloud fraction
   opts_scatt % cc_threshold          = -1

   ! test 4.1: setup the mw sensor
   call sensor_runtime_setup(sensor_mw,             &
                             ens_size=ens_size,     &
                             nlevs=numlevels,       &
                             opts=opts,             &
                             opts_scatt=opts_scatt)

   visir_md => null()
   mw_md    => mw_mds(1)
   channel  = 1

   ! test 4.4: call the MW scatt forward operator
   call do_forward_model(ens_size, numlevels, flavor, location,       &
      atmos, trace_gas, clouds, aerosols, sensor_mw, channel, &
      first_lvl_is_sfc, mw_clear_sky_only, clw_scheme,        &
      ice_scheme, idg_scheme, aerosl_type, do_lambertian,     &
      use_totalice, use_zeeman, radiances, error_status,      &
      visir_md=visir_md, mw_md=mw_md)

   write(string1,*) 'TB:',radiances

   call error_handler(E_MSG,'rttov_test',string1,&
      source, revision, revdate)

   call finalize_utilities('rttov_test')

end program rttov_test