!------------------------------------------------------------------------------!
!  The Community Multiscale Air Quality (CMAQ) system software is in           !
!  continuous development by various groups and is based on information        !
!  from these groups: Federal Government employees, contractors working        !
!  within a United States Government contract, and non-Federal sources         !
!  including research institutions.  These groups give the Government          !
!  permission to use, prepare derivative works of, and distribute copies       !
!  of their work in the CMAQ system to the public and to permit others         !
!  to do so.  The United States Environmental Protection Agency                !
!  therefore grants similar permission to use the CMAQ system software,        !
!  but users are requested to provide copies of derivative works or            !
!  products designed to operate in the CMAQ system to the United States        !
!  Government without restrictions as to use by others.  Software              !
!  that is used with the CMAQ system but distributed under the GNU             !
!  General Public License or the GNU Lesser General Public License is          !
!  subject to their copyright restrictions.                                    !
!------------------------------------------------------------------------------!

SUBROUTINE metvars2ctm

!-------------------------------------------------------------------------------
! Name:     Meteorology Variables to CTM (X) Grid
! Purpose:  Puts time-variant meteorology arrays on CTM (X) grid.
! Notes:    MM5 algorithms taken from original getmet_mm5.F.  Vegetation
!           information does not include seasonal changes.
! Revised:  20 Sep 2001  Original version.  (T. Otte)
!           03 Oct 2001  Updated calculation of XRNET.  (T. Otte and J. Pleim)
!           16 Oct 2001  Corrected error in translation between input
!                        domain and MCIP "X" domain.  (T. Otte)
!           21 Dec 2001  Changed order of variable declarations in interface
!                        to improve portability.  (S. Howard and T. Otte)
!           23 Jan 2002  Changed calls to "abort" to calls to "m3exit" for
!                        graceful shut-down of I/O API files.  Added updates
!                        to XFLAGS for variables filled here.  Changed missing
!                        value on XRSTOM to BADVAL3.  (T. Otte)
!           26 Mar 2003  Simplified algorithm to map input meteorology to
!                        MCIP_X domain.  Enabled dot-point MCIP_X arrays to
!                        be filled to the correct dimensions.  (T. Otte)
!           29 May 2003  Added minimum leaf area index and vegetation values
!                        to represent winter conditions for USGS land use.
!                        LAI and VEG are based on values used by Vegeland (for
!                        P-X) in MM5.  Also added F2 as a function of USGS land
!                        use.  Added translation of snow cover to MCIP_X domain.
!                        (T. Otte, J. Pleim, and D. Schwede)
!           09 Aug 2004  Added graupel processing.  Added 2-m temperature, if
!                        it is available from incoming meteorology.  Removed
!                        XFLAGS.  (T. Otte and D. Schwede)
!           26 May 2005  Removed NDX and option to interpolate to finer scale
!                        meteorology.  Added optimization of loops using F90
!                        implicit loop structures.  Removed unused variables
!                        REGIME and MAVAIL.  Changed XUU and XVV to XUU_D and
!                        XVV_D, and changed definitions to be input model-
!                        specific.  Added definitions of XUU_S and XVV_T.
!                        Added contents of MET3DSUP.  Added WRF algorithms.
!                        Added processing of 10-m wind components.  Added
!                        floor value for QV.  (T. Otte)
!           19 Aug 2005  Removed unused variables FSOIL and XFSOIL.  Changed
!                        internal variable EPSILON to EPSILONQ to avoid
!                        confusion with F90 intrinsic function.  (T. Otte)
!           13 Sep 2005  Changed logic for defining surface density from 2-m
!                        temperature to prevent "null pointer" error with
!                        PGF90 compiler.  (T. Otte)
!           19 Jun 2006  Removed dependency on module CONST_PBL.  Removed
!                        unused variables DETA, IIL, JJL, LVL, and LVLF1.
!                        (T. Otte)
!           30 Jul 2007  Removed algorithms that supported hydrostatic MM5
!                        output (e.g., from MM5v2).  Changed XUSTAR and XRADYN
!                        to 2D arrays without a dimension for fractional land
!                        use that was required for RADMdry.  Changed 2-m
!                        temperature from XT2 to XTEMP2.  Removed internal
!                        variables for emissivity and net radiation.  Moved
!                        land-use-based filling of F2 and RSTMIN to subroutine
!                        RESISTCALC.  Removed references to logical variable
!                        "PX" to make code more general.  (T. Otte)
!           28 Apr 2008  Changed setting for LAI to a fixed value if NOAH LSM
!                        was used with WRF and if LAI is not found in the input
!                        meteorology file(s).  Added 2-m mixing ratio and
!                        turbulent kinetic energy.  Changed to use gravitational
!                        constant and dry gas constant values from MM5 system
!                        rather than from CMAQ system for coordinate
!                        calculations.  Removed unused variable GRAVI, and
!                        removed dependency on module CONST.  Expanded lookup
!                        tables for LAI and VEG for 33-category USGS, and
!                        deleted unused lookup tables for RST.  (T. Otte)
!           29 Oct 2009  Added potential temperature and Coriolis for when
!                        potential vorticity is needed.  Added default values
!                        of LAI and VEG for MODIS-NOAH and NLCD-MODIS land-use
!                        classification systems.  Changed real number
!                        comparisons from "equivalences" to "less than
!                        tolerances".  (T. Otte)
!           19 Mar 2010  Corrected comment that provided Jacobian equations for
!                        WRF.  Corrected logic in LAI algorithm for when IFLAI
!                        is FALSE.  (T. Otte)
!           23 Dec 2010  Corrected scaling of XWR for WRF runs so that water
!                        density is used rather than air density.  (J. Pleim)
!                        Added sea ice.  Set ice threshold temperature over
!                        water to 271.36 K to be consistent with CMAQ. (T. Otte)
!           23 Feb 2010  Replaced statement functions with external routines.
!                        (T. Otte)
!           01 Sep 2011  Replaced module PARMS3 with I/O API module M3UTILIO.
!                        Improved error handling.  Replaced DATA statements
!                        with parameters.  (T. Otte)
!           07 Sep 2011  Updated disclaimer.  (T. Otte)
!           09 Sep 2011  Fill convective rain array with negative values if
!                        no cumulus parameterization was used in the
!                        meteorological model.  Works with change to sub-grid
!                        cloud scheme in CMAQv5.0.  (T. Otte)
!           10 Sep 2012  Added handling for 40-category 2006 NLCD-MODIS land
!                        use classification as "NLCD40".  Added alternate name
!                        for 50-category 2001 NLCD-MODIS land use classification
!                        as "NLCD50".  Appended "D50" to the ends of LAINLC,
!                        LAIMNNLC, VEGNLC, and VEGMNNLC to distinguish them
!                        for NLCD50.  Added analogous variables for NLCD40.
!                        Some of the values for NCLD50 were updated with the
!                        current values from module_sf_pxlsm_data.F from
!                        WRFv3.4.  The values for NCLD40 are also consistent
!                        with the same routine.  (T. Otte)
!           24 Apr 2015  Added 3D resolved cloud fraction to output if it is
!                        available in incoming meteorological model data.
!                        (T. Spero)
!           21 Aug 2015  Changed latent heat flux from QFX to LH.  Fill THETA
!                        and add moisture flux (QFX) for IFMOLACM.  (T. Spero)
!           17 Sep 2015  Changed IFMOLACM to IFMOLPX.  (T. Spero)
!           16 Mar 2018  Added SNOWH to output.  Changed calculation of Jacobian
!                        for hybrid vertical coordinate in WRF, but disabled it
!                        for this release until addtional modifications and
!                        testing with CMAQ can be conducted.  Calculate soil
!                        layer depths in XZSOIL, and map 3D soil data into 3D
!                        soil arrays.  Process data for NOAH Mosaic.  Added
!                        mapping of Noah wind speed and dynamic LAI.  (T. Spero)
!           28 Aug 2018  Enabled Jacobian calculation for hybrid vertical
!                        coordinate in WRF.  (T. Spero)
!           19 Sep 2018  Removed support for MM5v3 input.  Now use netCDF tokens
!                        for missing data.  Changed fill value for "no cumulus
!                        parameterization" from -1 to a large negative number
!                        to prevent inadverent use in CMAQ.  (T. Spero)
!           18 Jun 2019  Added new surface variables with PX LSM that can
!                        improve dust simulation in CCTM.  Added optional
!                        variables from KF convective scheme with radiative
!                        feedbacks.  (T. Spero)
!           13 May 2021  Corrected minor error in assigning bounds for XCLAY_PX
!                        as identified through CMAS Forum. (T. Spero)
!-------------------------------------------------------------------------------

  USE mcipparm
  USE metinfo
  USE xvars
  USE metvars

  IMPLICIT NONE

  INTEGER                           :: c
  INTEGER                           :: ec
  REAL,               PARAMETER     :: epsilonq   = 1.0e-30
  REAL,               PARAMETER     :: epsilonqv  = 1.0e-14
  INTEGER                           :: er
  REAL,               PARAMETER     :: giwrf      = 1.0 / 9.81  ! [s2/m]
  REAL,               PARAMETER     :: icethresh  = 271.36  ! [K]
  INTEGER                           :: ii
  INTEGER                           :: ilu
  INTEGER                           :: jj
  INTEGER                           :: k
  INTEGER                           :: kp1
  CHARACTER(LEN=16),  PARAMETER     :: pname      = 'METVARS2CTM'
  REAL                              :: qf
  INTEGER                           :: r
  REAL,               PARAMETER     :: rdovcp     = 2.0 / 7.0  ! Rd / cP
  REAL,               PARAMETER     :: rdwrf      = 287.0  ! [J/kg/K]
  REAL,               PARAMETER     :: rvwrf      = 461.6  ! [J/kg/K]
  INTEGER                           :: sc
  REAL,               PARAMETER     :: smallnum   = 1.0e-7
  INTEGER                           :: sr
  REAL                              :: tf
  REAL,               EXTERNAL      :: vtemp
  REAL                              :: wgt1
  REAL                              :: wgt2
  REAL                              :: z0
  REAL                              :: z1
  REAL                              :: z2

  INTERFACE

    SUBROUTINE layht (xx3face, xx3midl, x3jacobf, x3jacobm, x3htf, x3htm)
      IMPLICIT NONE
      REAL,               INTENT(OUT)   :: x3htf      ( : , : , : )
      REAL,               INTENT(OUT)   :: x3htm      ( : , : , : )
      REAL,               INTENT(IN)    :: x3jacobf   ( : , : , : )
      REAL,               INTENT(IN)    :: x3jacobm   ( : , : , : )
      REAL,               INTENT(IN)    :: xx3face    ( : )
      REAL,               INTENT(IN)    :: xx3midl    ( : )
    END SUBROUTINE layht

  END INTERFACE

!-------------------------------------------------------------------------------
! Land-use based arrays.
!-------------------------------------------------------------------------------

  REAL, PARAMETER :: laimod ( 33 ) = &
    (/  5.0,    5.0,    5.0,    5.0,    5.0,    3.0,    2.0,    2.5,    2.0,   &
        2.5,    3.0,    3.0,    3.0,    3.0,    0.1,    1.0,    0.0,    3.4,   &
        2.4,    1.4,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,   &
        0.0,    0.0,    0.0,    2.2,    2.1,    2.0 /)

  REAL, PARAMETER :: laimnmod ( 33 ) = &
    (/  3.0,    4.0,    1.0,    1.0,    2.0,    1.0,    1.0,    1.0,    1.0,   &
        1.0,    1.0,    0.5,    1.0,    1.0,    0.1,    0.5,    0.0,    2.0,   &
        1.0,    0.1,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,   &
        0.0,    0.0,    0.0,    0.7,    0.6,    0.5 /)

  REAL, PARAMETER :: lainlcd50 ( 50 ) = &
    (/  0.0,    0.1,    3.0,    3.0,    3.0,    3.0,    1.0,    0.5,    5.0,   &
        4.0,    5.0,    2.0,    2.5,    2.5,    2.0,    1.0,    1.0,    1.0,   &
        3.0,    3.0,    5.0,    5.0,    3.0,    5.0,    3.0,    2.0,    2.0,   &
        2.0,    1.0,    1.0,    0.0,    4.0,    5.0,    5.0,    5.0,    5.0,   &
        3.0,    2.5,    2.5,    2.0,    2.5,    3.0,    3.0,    3.0,    3.0,   &
        0.1,    1.0,    0.0,    0.0,    0.0 /)

  REAL, PARAMETER :: laimnnlcd50 ( 50 ) = &
    (/  0.0,    0.1,    1.0,    1.0,    1.0,    1.0,    0.5,    0.2,    1.0,   &
        3.0,    2.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,   &
        1.0,    0.5,    2.0,    2.0,    1.0,    2.0,    1.0,    1.0,    1.0,   &
        1.0,    0.5,    0.5,    0.0,    3.0,    4.0,    1.0,    1.0,    2.0,   &
        1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    0.5,    1.0,    1.0,   &
        0.1,    0.5,    0.0,    0.0,    0.0 /)

  REAL, PARAMETER :: lainlcd40 ( 40 ) = &
    (/  4.0,    5.0,    5.0,    5.0,    5.0,    3.0,    2.5,    2.5,    2.0,   &
        2.5,    3.0,    3.0,    3.0,    3.0,    0.1,    1.0,    0.0,    0.0,   &
        0.0,    0.0,    0.0,    0.1,    3.0,    3.0,    3.0,    3.0,    1.0,   &
        5.0,    4.0,    5.0,    2.0,    2.5,    2.5,    2.0,    1.0,    1.0,   &
        3.0,    3.0,    5.0,    2.0 /)

  REAL, PARAMETER :: laimnnlcd40 ( 40 ) = &
    (/  3.0,    4.0,    1.0,    1.0,    2.0,    1.0,    1.0,    1.0,    1.0,   &
        1.0,    1.0,    0.5,    1.0,    1.0,    0.1,    0.5,    0.0,    0.0,   &
        0.0,    0.0,    0.0,    0.1,    1.0,    1.0,    1.0,    1.0,    0.5,   &
        1.0,    3.0,    2.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,   &
        1.0,    0.5,    2.0,    1.0 /)

  REAL, PARAMETER :: laimm5 ( 13 ) = &
    (/  2.0,    3.0,    3.0,    5.0,    4.5,    5.0,    0.0,    2.0,    0.5,   &
        1.0,    0.0,    5.0,    2.0 /)

  REAL, PARAMETER :: laiusgs ( 33 ) = &
    (/  2.0,    3.0,    3.0,    3.0,    2.5,    4.0,    2.5,    3.0,    3.0,   &
        2.0,    5.0,    5.0,    5.0,    4.0,    5.0,    0.0,    2.0,    5.0,   &
        0.5,    1.0,    1.0,    1.0,    0.1,    0.1,    0.1,    0.1,    0.1,   &
        0.0,    0.0,    0.0,    2.2,    2.1,    2.0 /)

  REAL, PARAMETER :: laimnusgs ( 33 ) = &
    (/  0.5,    0.5,    0.5,    0.5,    1.0,    1.5,    1.0,    1.0,    1.0,   &
        1.0,    1.0,    1.0,    4.0,    3.0,    2.0,    0.0,    1.0,    3.0,   &
        0.2,    0.5,    0.5,    0.5,    0.1,    0.1,    0.1,    0.1,    0.1,   &
        0.0,    0.0,    0.0,    0.7,    0.6,    0.5 /)

  REAL, PARAMETER :: vegmod ( 33 ) = &
    (/  0.90,   0.95,   0.95,   0.95,   0.95,   0.90,   0.75,   0.80,   0.70,  &
        0.85,   0.75,   0.95,   0.40,   0.95,   0.05,   0.20,   0.00,   0.70,  &
        0.40,   0.20,   0.00,   0.00,   0.00,   0.00,   0.00,   0.00,   0.00,  &
        0.00,   0.00,   0.00,   0.50,   0.45,   0.40 /)

  REAL, PARAMETER :: vegmnmod ( 33 ) = &
    (/  0.80,   0.85,   0.50,   0.50,   0.60,   0.50,   0.50,   0.60,   0.50,  &
        0.60,   0.45,   0.10,   0.20,   0.40,   0.02,   0.05,   0.00,   0.50,  &
        0.20,   0.05,   0.00,   0.00,   0.00,   0.00,   0.00,   0.00,   0.00,  &
        0.00,   0.00,   0.00,   0.30,   0.25,   0.20 /)

  REAL, PARAMETER :: vegnlcd50 ( 50 ) = &
    (/  0.00,   0.05,   0.90,   0.70,   0.40,   0.15,   0.20,   0.15,   0.95,  &
        0.90,   0.95,   0.50,   0.75,   0.85,   0.80,   0.80,   0.80,   0.50,  &
        0.95,   0.95,   0.90,   0.90,   0.90,   0.90,   0.90,   0.60,   0.80,  &
        0.80,   0.60,   0.60,   0.00,   0.90,   0.95,   0.95,   0.95,   0.95,  &
        0.90,   0.75,   0.80,   0.70,   0.85,   0.75,   0.95,   0.40,   0.95,  &
        0.05,   0.20,   0.00,   0.00,   0.00 /)

  REAL, PARAMETER :: vegmnnlcd50 ( 50 ) = &
    (/  0.00,   0.02,   0.80,   0.60,   0.30,   0.05,   0.05,   0.05,   0.50,  &
        0.80,   0.60,   0.20,   0.50,   0.60,   0.20,   0.20,   0.20,   0.20,  &
        0.80,   0.10,   0.80,   0.80,   0.80,   0.80,   0.80,   0.40,   0.40,  &
        0.40,   0.20,   0.20,   0.00,   0.80,   0.85,   0.50,   0.50,   0.60,  &
        0.50,   0.50,   0.60,   0.50,   0.60,   0.45,   0.10,   0.20,   0.40,  &
        0.02,   0.05,   0.00,   0.00,   0.00 /)

  REAL, PARAMETER :: vegnlcd40 ( 40 ) = &
    (/  0.90,   0.95,   0.95,   0.95,   0.95,   0.90,   0.75,   0.80,   0.70,  &
        0.85,   0.75,   0.95,   0.40,   0.95,   0.05,   0.20,   0.00,   0.00,  &
        0.00,   0.00,   0.00,   0.05,   0.90,   0.70,   0.40,   0.15,   0.20,  &
        0.95,   0.90,   0.95,   0.50,   0.75,   0.85,   0.80,   0.80,   0.80,  &
        0.95,   0.95,   0.90,   0.60 /)

  REAL, PARAMETER :: vegmnnlcd40 ( 40 ) = &
    (/  0.80,   0.85,   0.50,   0.50,   0.60,   0.50,   0.50,   0.60,   0.50,  &
        0.60,   0.45,   0.10,   0.20,   0.40,   0.02,   0.05,   0.00,   0.00,  &
        0.00,   0.00,   0.00,   0.02,   0.80,   0.60,   0.30,   0.05,   0.05,  &
        0.50,   0.80,   0.60,   0.20,   0.50,   0.60,   0.20,   0.20,   0.20,  &
        0.80,   0.10,   0.80,   0.40 /)

  REAL, PARAMETER :: vegmm5 ( 13 ) = &
    (/  0.40,   0.95,   0.95,   0.95,   0.95,   0.95,   0.00,   0.75,   0.10,  &
        0.20,   0.00,   0.90,   0.80 /)

  REAL, PARAMETER :: vegusgs ( 33 ) = &
    (/  0.40,   0.95,   0.95,   0.95,   0.95,   0.95,   0.95,   0.70,   0.85,  &
        0.80,   0.95,   0.95,   0.95,   0.90,   0.95,   0.00,   0.60,   0.90,  &
        0.10,   0.20,   0.30,   0.20,   0.05,   0.05,   0.02,   0.02,   0.02,  &
        0.00,   0.00,   0.00,   0.50,   0.45,   0.40 /)

  REAL, PARAMETER :: vegmnusgs ( 33 ) = &
    (/  0.20,   0.15,   0.10,   0.15,   0.35,   0.40,   0.70,   0.50,   0.60,  &
        0.60,   0.50,   0.50,   0.85,   0.80,   0.60,   0.00,   0.40,   0.80,  &
        0.05,   0.10,   0.10,   0.05,   0.02,   0.02,   0.01,   0.01,   0.01,  &
        0.00,   0.00,   0.00,   0.30,   0.25,   0.20 /)

!-------------------------------------------------------------------------------
! Error, warning, and informational messages.
!-------------------------------------------------------------------------------

  CHARACTER(LEN=256), PARAMETER :: f9000 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   UNKNOWN LAND USE INPUT DATA SOURCE', &
    & /, 1x, '***   DATA SOURCE IS ', a, &
    & /, 1x, 70('*'))"

!-------------------------------------------------------------------------------
! Put time-variant cross-point arrays on MCIP_X grid.
!-------------------------------------------------------------------------------

  sc = x0
  ec = x0 + ncols_x - 1
  sr = y0
  er = y0 + nrows_x - 1

  xtempg (:,:) = groundt (sc:ec,sr:er)
  IF ( met_model == 2 .AND. met_cumulus == 0 ) THEN  ! no cumulus scheme
    xrainc (:,:) = fillreal  ! fill with negative values as flag for CMAQv5.0
  ELSE
    xrainc (:,:) = raincon (sc:ec,sr:er)  ! rain is already incremental here
  ENDIF
  xrainn (:,:) = rainnon (sc:ec,sr:er)    ! rain is already incremental here
  xpbl   (:,:) = zpbl    (sc:ec,sr:er)
  xhfx   (:,:) = hfx     (sc:ec,sr:er)
  xlh    (:,:) = lh      (sc:ec,sr:er)
  xustar (:,:) = ust     (sc:ec,sr:er)
  xrgrnd (:,:) = rgrnd   (sc:ec,sr:er)
  xglw   (:,:) = glw     (sc:ec,sr:er)
  xzruf  (:,:) = znt     (sc:ec,sr:er)
  xalbedo(:,:) = albedo  (sc:ec,sr:er)
  xsnocov(:,:) = snowcovr(sc:ec,sr:er)
  xsnowh (:,:) = snowh   (sc:ec,sr:er)

  xgsw   (:,:) = xrgrnd(:,:) * ( 1.0 - xalbedo(:,:) )

  IF ( ift2m ) THEN
    xtemp2(:,:) = t2     (sc:ec,sr:er)
  ELSE
!  ~ Calculate in PBLSUP.
  ENDIF

  IF ( ifq2m ) THEN
    xq2   (:,:) = q2     (sc:ec,sr:er)
  ELSE
    xq2   (:,:) = qva    (sc:ec,sr:er,1)  ! fill Q2 with QV from layer 1
  ENDIF

  IF ( ifw10m ) THEN
    xu10 (:,:) = u10     (sc:ec,sr:er)
    xv10 (:,:) = v10     (sc:ec,sr:er)
  ELSE
!  ~ Calculate in PBLSUP.
  ENDIF

  IF ( ifmolpx ) THEN
    xqfx(:,:) = qfx(sc:ec,sr:er)
  ENDIF

  IF ( iflai .AND. ifpxwrf41 ) THEN
      xlai(:,:) = lai_px(sc:ec,sr:er)
  ELSE IF ( iflai  .AND. ( MAXVAL(lai) > smallnum ) ) THEN
      xlai(:,:) = lai(sc:ec,sr:er)
  ELSE

    IF ( ( met_model == 2 ) .AND. ( met_soil_lsm == 2 ) ) THEN
      xlai(:,:) = 4.0
    ELSE

      DO c = 1, ncols_x
        ii = x0 + c - 1
        DO r = 1, nrows_x
          jj = y0 + r - 1

          ilu = landuse(ii,jj)

          IF ( met_lu_src(1:3) == "USG" ) THEN       ! USGS 24- or 33-cat. l.u.
            IF ( met_season == 1 ) THEN         ! summer
              xlai (c,r) = laiusgs(ilu)
            ELSE IF ( met_season == 2 ) THEN    ! winter
              xlai (c,r) = laimnusgs(ilu)
            ENDIF
          ELSE IF ( met_lu_src(1:3) == "OLD" ) THEN  ! MM5 13-category old l.u.
            xlai   (c,r) = laimm5(ilu)
          ELSE IF ( met_lu_src(4:6) == "D50" ) THEN  ! NLCD-MODIS 50-cat. l.u.
            IF ( met_season == 1 ) THEN         ! summer
              xlai (c,r) = lainlcd50(ilu)
            ELSE IF ( met_season == 2 ) THEN    ! winter
              xlai (c,r) = laimnnlcd50(ilu)
            ENDIF
          ELSE IF ( met_lu_src(4:6) == "D40" ) THEN  ! NLCD-MODIS 40-cat. l.u.
            IF ( met_season == 1 ) THEN         ! summer
              xlai (c,r) = lainlcd40(ilu)
            ELSE IF ( met_season == 2 ) THEN    ! winter
              xlai (c,r) = laimnnlcd40(ilu)
            ENDIF
          ELSE IF ( met_lu_src(1:3) == "MOD" ) THEN  ! MODIS-NOAH 20/33-cat.
            IF ( met_season == 1 ) THEN         ! summer
              xlai (c,r) = laimod(ilu)
            ELSE IF ( met_season == 2 ) THEN    ! winter
              xlai (c,r) = laimnmod(ilu)
            ENDIF
          ELSE
            WRITE (*,f9000) TRIM(pname), TRIM(met_lu_src)
            CALL graceful_stop (pname)
          ENDIF

        ENDDO
      ENDDO
    ENDIF

  ENDIF  ! iflai

  IF ( ifveg ) THEN
    xveg   (:,:) = veg   (sc:ec,sr:er)
  ELSE
    DO c = 1, ncols_x
      ii = x0 + c - 1
      DO r = 1, nrows_x
        jj = y0 + r - 1

        ilu = landuse(ii,jj)

        IF ( met_lu_src(1:3) == "USG" ) THEN       ! USGS 24- or 33-cat. l.u.
          IF ( met_season == 1 ) THEN         ! summer
            xveg (c,r) = vegusgs(ilu)
          ELSE IF ( met_season == 2 ) THEN    ! winter
            xveg (c,r) = vegmnusgs(ilu)
          ENDIF
        ELSE IF ( met_lu_src(1:3) == "OLD" ) THEN  ! MM5 13-category old l.u.
          xveg   (c,r) = vegmm5(ilu)
        ELSE IF ( met_lu_src(4:6) == "D50" ) THEN  ! NLCD-MODIS 50-cat. l.u.
          xveg   (c,r) = vegnlcd50(ilu)
        ELSE IF ( met_lu_src(4:6) == "D40" ) THEN  ! NLCD-MODIS 40-cat. l.u.
          xveg   (c,r) = vegnlcd40(ilu)
        ELSE IF ( met_lu_src(1:3) == "MOD" ) THEN  ! MODIS-NOAH 20/33-cat.
          xveg   (c,r) = vegmod(ilu)
        ELSE
          WRITE (*,f9000) TRIM(pname), TRIM(met_lu_src)
          CALL graceful_stop (pname)
        ENDIF

      ENDDO
    ENDDO
  ENDIF

  IF ( ifresist ) THEN

    xradyn (:,:) = ra    (sc:ec,sr:er)
    xrstom (:,:) = rstom (sc:ec,sr:er)

    ! At water points, stomatal resistance is 0.0.  Since
    ! inverse of XRSTOM is output in ctmproc.f90, need to avoid
    ! division by 0.0.  Use netCDF token as place-holder.

    WHERE ( xrstom == 0.0 ) xrstom = fillreal

  ELSE
!  ~ Calculate in RESISTCALC.
  ENDIF

  IF ( ifmol ) THEN
    xmol (:,:)    = mol (sc:ec,sr:er)
  ELSE
!  ~ Calculate in PBLSUP.
  ENDIF

  IF ( ifwr ) THEN
    xwr  (:,:)    = wr (sc:ec,sr:er)
    IF ( met_model == 2 ) THEN  ! WRF: divide by water density
      xwr(:,:) = xwr(:,:) * 0.001  ! kg/m2 -> m
    ENDIF
  ELSE
!  ~ Approximate in M3DRY and do not output.
  ENDIF

  IF ( .NOT. needseaice ) THEN
    xseaice(:,:) = seaice(sc:ec,sr:er)
  ELSE
    DO c = 1, ncols_x
      DO r = 1, nrows_x
        IF ( ( NINT(xlwmask(c,r)) == 0 ) .AND.  &
             ( xtempg(c,r) <= icethresh ) ) THEN  ! very cold water
          xseaice(c,r) = 1.0  ! ice
        ELSE
          xseaice(c,r) = 0.0  ! not ice
        ENDIF
      ENDDO
    ENDDO
  ENDIF

  IF ( ifsoil ) THEN
    xw2a   (:,:)   =        w2    (sc:ec,sr:er)
    xwga   (:,:)   =        wg    (sc:ec,sr:er)
    xsltyp (:,:)   = FLOAT( isltyp(sc:ec,sr:er) )
    xtga   (:,:)   =        soilt1(sc:ec,sr:er)
    xt2a   (:,:)   =        soilt2(sc:ec,sr:er)
    xsoim3d(:,:,:) =        soim3d(sc:ec,sr:er,:)
    xsoit3d(:,:,:) =        soit3d(sc:ec,sr:er,:)
  ELSE
!  ~ Downstream options that request these fields cannot be invoked
!  ~ as they will not be in the output.
  ENDIF

  IF ( ifmosaic ) THEN
    xlai_mos(:,:,:) = lai_mos(sc:ec,sr:er,:)
    xrs_mos (:,:,:) =  rs_mos(sc:ec,sr:er,:)
    xtsk_mos(:,:,:) = tsk_mos(sc:ec,sr:er,:)
    xznt_mos(:,:,:) = znt_mos(sc:ec,sr:er,:)
    xwspdsfc(:,:)   = wspdsfc(sc:ec,sr:er)
    xxlaidyn(:,:)   = xlaidyn(sc:ec,sr:er)
  ENDIF

  IF ( ifpxwrf41 ) THEN
    xwwlt_px(:,:)   = wwlt_px  (sc:ec,sr:er)
    xwfc_px(:,:)    = wfc_px   (sc:ec,sr:er)
    xwsat_px(:,:)   = wsat_px  (sc:ec,sr:er)
    xcsand_px(:,:)  = csand_px (sc:ec,sr:er)
    xfmsand_px(:,:) = fmsand_px(sc:ec,sr:er)
    xclay_px(:,:)   = clay_px  (sc:ec,sr:er)
  ENDIF

  IF ( lpv > 0 ) THEN
    xcorl  (:,:)  = coriolis(sc:ec,sr:er)
  ENDIF

  xtempm (:,:,:)  = ta (sc:ec,sr:er,:)
  xwvapor(:,:,:)  = qva(sc:ec,sr:er,:)
  xcldwtr(:,:,:)  = qca(sc:ec,sr:er,:)
  xranwtr(:,:,:)  = qra(sc:ec,sr:er,:)
  xqice  (:,:,:)  = qia(sc:ec,sr:er,:)
  xqsnow (:,:,:)  = qsa(sc:ec,sr:er,:)
  xqgraup(:,:,:)  = qga(sc:ec,sr:er,:)

  IF ( ifkfradextras ) THEN
    xqc_cu  (:,:,:)  = qc_cu    (sc:ec,sr:er,:)
    xqi_cu  (:,:,:)  = qi_cu    (sc:ec,sr:er,:)
    xcldfrad(:,:,:)  = cldfra_dp(sc:ec,sr:er,:)
    xcldfras(:,:,:)  = cldfra_sh(sc:ec,sr:er,:)
  ENDIF

  xwwind (:,:,0:) = wa(sc:ec,sr:er,1:)

  IF ( ( iftke ) .AND. ( .NOT. iftkef ) ) THEN  ! TKE on half-layers
    xtke   (:,:, :) = tke(sc:ec,sr:er, :)
  ELSE IF ( ( iftke ) .AND. ( iftkef ) ) THEN   ! TKE on full-levels
    xtke   (:,:,0:) = tke(sc:ec,sr:er,1:)
  ENDIF

  ! Ensure that very small (and sometimes negative!) values from WRF moisture
  ! fields are not used.  Here, EPSILONQ is the same minimum value as is set
  ! in ctmproc.f90.  Floor value for XWVAPOR (EPSILONQV) is based on MM5 value.

  WHERE ( xwvapor < epsilonqv ) xwvapor = epsilonqv
  WHERE ( xcldwtr < epsilonq  ) xcldwtr = 0.0
  WHERE ( xranwtr < epsilonq  ) xranwtr = 0.0
  WHERE ( xqice   < epsilonq  ) xqice   = 0.0
  WHERE ( xqsnow  < epsilonq  ) xqsnow  = 0.0
  WHERE ( xqgraup < epsilonq  ) xqgraup = 0.0

  IF ( ifkfradextras ) THEN
    WHERE ( xqc_cu  < epsilonq  ) xqc_cu  = 0.0
    WHERE ( xqi_cu  < epsilonq  ) xqi_cu  = 0.0
  ENDIF

!-------------------------------------------------------------------------------
! Put time-variant dot-point arrays on MCIP_X grid.  XUU_D and XVV_D are on
! B-grid (dot points).  XUU_S and XVV_T are on C-grid (face points).
!-------------------------------------------------------------------------------

  sc = x0
  ec = x0 + ncols_x
  sr = y0
  er = y0 + nrows_x

  IF ( met_model == 2 ) THEN  ! WRF: UA and VA on C-grid (face points)

    xuu_d(:,1,        :) = ua(sc:ec,sr,:)
    xuu_d(:,2:nrows_x,:) = 0.5 * (ua(sc:ec,sr:er-2,:) + ua(sc:ec,sr+1:er-1,:))
    xuu_d(:,nrows_x+1,:) = ua(sc:ec,er-1,:)
    xvv_d(1,        :,:) = va(sc,sr:er,:)
    xvv_d(2:ncols_x,:,:) = 0.5 * (va(sc:ec-2,sr:er,:) + va(sc+1:ec-1,sr:er,:))
    xvv_d(ncols_x+1,:,:) = va(ec-1,sr:er,:)

    xuu_s(:,:,:)         = ua(sc:ec,sr:er,:)
    xvv_t(:,:,:)         = va(sc:ec,sr:er,:)

  ENDIF

!------------------------------------------------------------------------------
! Compute pressure and potential temperature (if necessary).  Put cloud
! fraction on transfer grid, if available.
!------------------------------------------------------------------------------

  sc = x0
  ec = x0 + ncols_x - 1
  sr = y0
  er = y0 + nrows_x - 1

  IF ( met_model == 2 ) THEN  ! WRF

    xpresm(:,:,:) = pb (sc:ec,sr:er,:) + pp(sc:ec,sr:er,:)
    xmu   (:,:)   = mub(sc:ec,sr:er)   + mu(sc:ec,sr:er)
    xgeof (:,:,:) = phb(sc:ec,sr:er,:) + ph(sc:ec,sr:er,:)

    ! As of WRFv2.0.3.1, PSFC = 0.0 at WRF initial time.

    IF ( MINVAL(psa) > 0.0 ) THEN
      xprsfc(:,:) = psa(sc:ec,sr:er)  ! PSA contains PSFC for WRF
    ELSE
      DO c = 1, ncols_x
        DO r = 1, nrows_x
          z0   = xgeof(c,r,0)   ! Z0, Z1, Z2 really defined as Zx/grav
          z1   = 0.5 * ( xgeof(c,r,0) + xgeof(c,r,1) )
          z2   = 0.5 * ( xgeof(c,r,1) + xgeof(c,r,2) )
          wgt1 = (z2 - z0) / (z2 - z1)
          wgt2 = 1.0 - wgt1
          xprsfc(c,r) = wgt1 * xpresm(c,r,1) + wgt2 * xpresm(c,r,2)
        ENDDO
      ENDDO
    ENDIF

    xpresf(:,:,0) = xprsfc(:,:)

    ! Calculate full-level pressure from geopotential and hydrostatic equation.
    ! Assume temperature at mid-layers is sufficient "average" between full
    ! levels.

    DO k = 1, metlay
      xpresf(:,:,k) = xpresf(:,:,k-1) *  &
                      EXP( (xgeof(:,:,k-1) - xgeof(:,:,k)) /  &
                           (rdwrf * xtempm(:,:,k)) )
    ENDDO

    IF ( lpv > 0 .OR. ifmolpx ) THEN  ! need theta
      xtheta(:,:,:) = theta(sc:ec,sr:er,:)
    ENDIF

    IF ( ifcld3d ) THEN  ! passing through 3D cloud fraction
      xcfrac3d(:,:,:) = cldfra(sc:ec,sr:er,:)
    ENDIF

  ENDIF

!------------------------------------------------------------------------------
! Compute density.
! IF using WRF output and if canopy wetness is in the output, convert from
! kg m^-2 to m by dividing by density.
!------------------------------------------------------------------------------

  IF ( met_model == 2 ) THEN  ! WRF

    DO k = 1, metlay
      kp1 = MIN(k+1,metlay)

      DO c = 1, ncols_x
        DO r = 1, nrows_x

          ! Use formula for "alt" (total inverse density, alpha) from WRF's
          ! module_initialize_real.F, and replace potential temperature with
          ! temperature using Poisson's equation.  Density is 1./alt.  Note
          ! that this computed density matches well (to 6 or so decimal places)
          ! with WRF's prognostic density, expressed as 1./(alb+al); alb and al
          ! are not in the default WRF Registry as output to the history file
          ! (as of v2.0.3.1).  It only matches to 3 decimal places with 1./alt
          ! when alt is output in the WRF history file.

          xdensam(c,r,k) = ( xpresm(c,r,k) / ( rdwrf * xtempm(c,r,k) *  &
                             (1.0 + rvwrf*xwvapor(c,r,k)/rdwrf) ) )

          tf = 0.5 * (xtempm (c,r,k) + xtempm (c,r,kp1))
          qf = 0.5 * (xwvapor(c,r,k) + xwvapor(c,r,kp1))

          xdensaf(c,r,k) = ( xpresf(c,r,k) / ( rdwrf * tf *  &
                             (1.0 + rvwrf*qf/rdwrf) ) )

        ENDDO
      ENDDO
    ENDDO

    IF ( ( ift2m ) .AND. ( MAXVAL(xtemp2) > smallnum ) ) THEN  ! T2 = 0 at init
      xdensaf(:,:,0) = ( xpresf(:,:,0) / ( rdwrf * xtemp2(:,:) *      &
                         (1.0 + rvwrf*xwvapor(:,:,1)/rdwrf) ) )
    ELSE
      xdensaf(:,:,0) = ( xpresf(:,:,0) / ( rdwrf * xtempm(:,:,1) *  &
                         (1.0 + rvwrf*xwvapor(:,:,1)/rdwrf) ) )
    ENDIF
    xdenss(:,:) = xdensaf(:,:,0)

  ENDIF

  xdenswm(:,:,:) = xdensam(:,:,:) * xwvapor(:,:,:) / ( 1.0 + xwvapor(:,:,:) )

!-------------------------------------------------------------------------------
! If input meteorology has a time-varying vertical coordinate, compute Jacobian
! and layer heights.
!-------------------------------------------------------------------------------

  IF ( met_model == 2 ) THEN

    IF ( met_hybrid >= 0 ) THEN
      DO k = 0, metlay
        ! Adjust mu (a.k.a., ps - ptop) for hybrid coordinate.
        ! Calculate Jacobian from WRF relation:
        !   J*g = - d(phi)/d(eta) = - d(g z)/d(eta) = mu alpha = mu/rho
        xmuhyb(:,:)     = c1f(k+1) * xmu(:,:) + c2f(k+1)
        x3jacobf(:,:,k) = giwrf  * xmuhyb(:,:) / xdensaf(:,:,k)
        IF ( k == 0 ) CYCLE
        xmuhyb(:,:)     = c1h(k) * xmu(:,:) + c2h(k)
        x3jacobm(:,:,k) = giwrf  * xmuhyb(:,:) / xdensam(:,:,k)
      ENDDO
    ELSE
      DO k = 0, metlay
        ! Calculate Jacobian from WRF relation:
        !   J*g = - d(phi)/d(eta) = - d(g z)/d(eta) = mu alpha = mu/rho
        x3jacobf(:,:,k) = giwrf * xmu(:,:) / xdensaf(:,:,k)
        IF ( k == 0 ) CYCLE
        x3jacobm(:,:,k) = giwrf * xmu(:,:) / xdensam(:,:,k)
      ENDDO
    ENDIF

    CALL layht  (xx3face, xx3midl, x3jacobf, x3jacobm, x3htf, x3htm)

  ENDIF

!-------------------------------------------------------------------------------
! Calculate height differences.
!-------------------------------------------------------------------------------

  DO k = 1, metlay
    xdx3htf(:,:,k) = x3htf(:,:,k) - x3htf(:,:,k-1)  ! X3HTF starts at 0 in vert
  ENDDO

!-------------------------------------------------------------------------------
! Calculate contravariant velocity (w-component).
!-------------------------------------------------------------------------------

  IF ( met_model == 2 ) THEN  ! WRF-ARW
    CALL vertnhy_wrf
  ENDIF

!-------------------------------------------------------------------------------
! Calculate depths of soil layers.
!-------------------------------------------------------------------------------

  IF ( met_model == 2 ) THEN  ! WRF-ARW
    IF ( met_ns > 0 ) THEN
      DO k = 1, met_ns
        xzsoil(k) = 0.0 - (SUM(dzs(1:k)))  ! m
      ENDDO
    ENDIF
  ENDIF

END SUBROUTINE metvars2ctm


      subroutine genclustphotons(q,R,qfinal,isub)
c--- this is a wrapper routine for the jet clustering algorithm
c--- which re-routes according to the value of 'algorithm'  to:
c---  ('ktal') genclust_kt.f     for kt clustering
c---  ('ankt') genclust_kt.f     for "anti-kt" clustering
c---  ('cone') genclust_cone.f   for cone algorithm
c---  ('hqrk') genclust_hqrk.f   for simplified heavy-quark algorithm
c---  ('none') to perform no clustering at all
      implicit none
      include 'constants.f'
      include 'clustering.f'
      include 'jetcuts.f'
      include 'jetlabel.f'
      include 'bbproc.f'
      include 'process.f'
      include 'part.f'
      include 'nqcdjets.f'
      double precision q(mxpart,4),qfinal(mxpart,4),
     & qreorder(mxpart,4),R
      integer isub,i,nu
      logical first
      data first/.true./
      save first
!$omp threadprivate(first)

      if ((first) .and. ((nqcdjets .gt. 0).or.(part .eq. 'real'))) then
        first=.false.
        call read_jetcuts(ptjetmin,etajetmin,etajetmax)
      write(6,*)
      write(6,*) '*********** Basic jet-defining parameters **********'
      if     (algorithm .eq. 'ktal') then
      write(6,*) '*          (Run II kT clustering algorithm)        *'
      elseif (algorithm .eq. 'ankt') then
      write(6,*) '*     (Anti-kt algorithm - see arXiv:0802.1189)    *'
      elseif (algorithm .eq. 'cone') then
      write(6,*) '*              (Run II cone algorithm)             *'
      elseif (algorithm .eq. 'hqrk') then
      write(6,*) '*        (Simple cone algorithm for W/Z+Q+j)       *'
      elseif (algorithm .eq. 'none') then
      write(6,*) '*             (no clustering algorithm)            *'
      else
      write(6,*)
      write(6,*) 'Invalid selection of algorithm in input file.'
      write(6,*) 'Please select either ktal, cone, hqrk or none'
      stop
      endif
      write(6,*) '*                                                  *'
      write(6,79) ' *     pt(jet)         > ',ptjetmin
      write(6,79) ' *   |pseudo-rap(jet)| > ',etajetmin
      write(6,79) ' *   |pseudo-rap(jet)| < ',etajetmax
      if (bbproc) then
        ptbjetmin=max(ptjetmin,ptbjetmin)
        etabjetmax=min(etajetmax,etabjetmax)
      write(6,79) ' *   pt(b-jet)         > ',ptbjetmin
      write(6,79) ' * |pseudo-rap(b-jet)| < ',etabjetmax
      endif
      if (algorithm .eq. 'hqrk') then
c      write(6,79) ' *   b-bbar separation : ',Rbbmin
      write(6,79) ' *        cone size, R : ',R
      else
      write(6,79) ' * pseudo-cone size, R : ',R
      endif
      write(6,*) '*                                                  *'
      if ((case .eq. 'W_twdk') .or. (case .eq. 'Wtdkay')) then
      write(6,79) ' *   pt(b-jet @ NLO)   < ',ptbjetmin
      write(6,*) '*                                                  *'
      endif
      if (inclusive) then
      write(6,*) '*        Jet cross-section is INCLUSIVE            *'
      else
      write(6,*) '*        Jet cross-section is EXCLUSIVE            *'
      endif
      write(6,*) '****************************************************'
      call flush(6)
      endif
   79 format(a25,f8.4,'                   *')

      if     (algorithm .eq. 'ktal') then
        call photgenclust(q,R,qfinal,isub,+1)
      elseif (algorithm .eq. 'ankt') then
        call photgenclust(q,R,qfinal,isub,-1)
      elseif (algorithm .eq. 'cone') then
       write(6,*) 'ERROR CONE ALGORITHM NOT IMPLEMENTED'
         return
c        call genclust_cone(q,R,qfinal,isub)
      elseif (algorithm .eq. 'hqrk') then
         write(6,*) 'ERROR HQRK ALGORITHM NOT IMPLEMENTED'
         return
c        call genclust_hqrk(q,R,qfinal,isub)
      elseif (algorithm .eq. 'none') then
        do i=1,mxpart
          do nu=1,4
            qfinal(i,nu)=q(i,nu)
          enddo
        enddo
        jets=nqcdjets
      if ((part .eq. 'real') .and. (isub .eq. 0)) jets=jets+1
        return
      else
        write(6,*) 'Invalid choice of jet algorithm, must be'
        write(6,*) '   ktal, ankt, cone, hqrk, none'
        stop
      endif

c--- reorder jets for some special cases, to preserve identities of
c--- particles for use in the plotting routines
      if (    (case .eq. 'qq_ttg')
     &   .or. (case .eq. 'tt_bbl')
     &   .or. (case .eq. 'tt_bbh')) then
      call jetreorder(qfinal,qreorder,isub)
      do i=1,mxpart
        do nu=1,4
          qfinal(i,nu)=qreorder(i,nu)
        enddo
      enddo
      endif

      return
      end


    module CosmoTheory
    use settings
    use CosmologyTypes
    use GeneralTypes
    use likelihood
    use Interpolation
    implicit none
    private

    Type, extends(TInterpGrid2D) :: TCosmoTheoryPK
        !whether power is stored as log(P_k)
        logical :: islog = .true.
    contains
    procedure :: PowerAt
    end Type TCosmoTheoryPK

    Type TSkyPowerSpectrum
        real(mcp), allocatable :: CL(:)
    end Type TSkyPowerSpectrum

    Type, extends(TTheoryPredictions) :: TCosmoTheoryPredictions
        Type(TSkyPowerSpectrum), allocatable :: Cls(:,:)
        !(T, E, B, Phi) x (T, E, B, Phi), with L(L+1)/2pi factor, in muK for CMB components
        real(mcp) sigma_8
        real(mcp) tensor_ratio_C10, tensor_ratio_02, tensor_ratio_BB, tensor_AT
        real(mcp) :: Lensing_rms_deflect = 0._mcp
        integer numderived
        real(mcp) derived_parameters(max_derived_parameters)
        !MPK's are interpolator objects now
        !MPK%x = logkh, MPK%y = z (redshift), MPK%z =>actual data array
        !MPK%nx = num_k, MPK%ny = num_z
        type(TCosmoTheoryPK), allocatable :: MPK
        type(TCosmoTheoryPK), allocatable :: NL_MPK
        type(TCosmoTheoryPK), allocatable :: MPK_WEYL
        type(TCosmoTheoryPK), allocatable :: NL_MPK_WEYL
        type(TCubicSpline),  allocatable :: growth_z !defined as sigma8_vd^2/sigma8
        type(TCubicSpline),  allocatable :: sigma8_z
        type(TCubicSpline),  allocatable :: sigma_R
        type(TNLRSD_tables)              :: NLRSD !AGS: NLRSD model
    contains
    procedure :: FreePK
    procedure :: ClArray
    procedure :: ClsAtL
    procedure :: WriteTextCls
    procedure :: AllocateForSettings => TCosmoTheoryPredictions_AllocateForSettings
    !Inherited overrides
    procedure :: WriteTheory => TCosmoTheoryPredictions_WriteTheory
    procedure :: ReadTheory => TCosmoTheoryPredictions_ReadTheory
    procedure :: WriteTextData => TCosmoTheoryPredictions_WriteTextData
    end Type TCosmoTheoryPredictions

    public TCosmoTheoryPredictions, TCosmoTheoryPK,  TSkyPowerSpectrum
    contains

    function PowerAt(PK,k,z) result(outpower)
    class(TCosmoTheoryPK) PK
    real(mcp), intent(in) :: k,z
    real(mcp) :: logk
    real(mcp) :: outpower

    logk=log(k)
    if(.not. allocated(PK%x)) then
        write(*,*) 'ERROR:  PowerAt least one of your PK arrays is not initialized:'
        write(*,*) '        Make sure you are calling a SetPk and filling your power spectra.'
        write(*,*) '        This error could also mean you are doing importance sampling'
        write(*,*) '        and need to turn on redo_pk.'
        call MPIstop()
    end if

    if(PK%islog) then
        outpower = exp(PK%Value(logk,z))
    else
        outpower = PK%Value(logk,z)
    end if

    end function PowerAt

    subroutine FreePK(this)
    class(TCosmoTheoryPredictions) this

    if(allocated(this%MPK)) deallocate(this%MPK)
    if(allocated(this%NL_MPK)) deallocate(this%NL_MPK)
    if(allocated(this%MPK_WEYL)) deallocate(this%MPK_WEYL)
    if(allocated(this%NL_MPK_WEYL)) deallocate(this%NL_MPK_WEYL)

    end subroutine FreePK

    subroutine ClArray(this, cl, i, j)
    class(TCosmoTheoryPredictions) this
    real(mcp) :: cl(1:)
    integer i, j, ii,jj,outmax, inmax,mx

    if (j>i) then
        jj=i
        ii=j
    else
        ii=i
        jj=j
    end if
    if (allocated(this%Cls(ii,jj)%Cl)) then
        outmax = size(cl)
        inmax = size(this%Cls(ii,jj)%Cl)
        mx = min(outmax,inmax)
        cl(1:mx) = this%Cls(ii,jj)%Cl(1:mx)
        cl(mx+1:outmax)=0
    else
        call MpiStop('CosmoTheory: ClArray not calcualated')
    end if

    end subroutine ClArray

    subroutine ClsAtL(this, L, cl, max_ix_out)
    !TT EE TE BB BE BT PP.. order
    class(TCosmoTheoryPredictions) this
    real(mcp):: cl(:)
    integer, intent(in) :: L
    integer, intent(in), optional ::max_ix_out
    integer imax,ix,i,j, inmax

    imax = PresentDefault(size(this%Cls,2),max_ix_out)
    ix=0
    do i=1,min(size(this%Cls,2),imax)
        do j= i, 1, -1
            ix = ix+1
            if (allocated(this%Cls(i,j)%CL)) then
                inmax = size(this%Cls(i,j)%Cl)
                if (inmax >= L) then
                    cl(ix) = this%Cls(i,j)%Cl(L)
                else
                    cl(ix)=0
                end if
            else
                cl(ix) = 0
            end if
        end do
    end do

    end subroutine ClsAtL

    subroutine WriteTextCls(this,aname)
    class(TCosmoTheoryPredictions) this
    character (LEN=*), intent(in) :: aname
    integer l
    real(mcp), allocatable :: cl(:,:)
    Type(TTextFile) :: F
    character(LEN=*), parameter :: fmt = '(1I6,*(E15.5))'
    integer i, j, n, ix
    character(LEN=:), allocatable :: fields

    n = count(CosmoSettings%cl_lmax>0)
    allocate(cl(CosmoSettings%lmax,n), source=0._mcp)
    ix=0
    fields = '#    L    '
    do i = 1, size(this%Cls,2)
        do j=1,i
            if (CosmoSettings%cl_lmax(i,j)>0) then
                ix=ix+1
                call this%ClArray(cl(:,ix),i,j)
                fields = fields // CMB_CL_Fields(j:j)//CMB_CL_Fields(i:i)//'             '
            end if
        end do
    end do

    call F%CreateFile(aname)
    call F%WriteTrim(fields)
    do l = 2, CosmoSettings%lmax
        write(F%unit,fmt) L,cl(L,:)
    end do
    call F%Close()

    end subroutine WriteTextCls

    subroutine TCosmoTheoryPredictions_WriteTheory(this, F, first)
    Class(TCosmoTheoryPredictions) this
    class(TFileStream) :: F
    logical, intent(in) :: first
    integer ArraySizes(1)
    real(mcp) :: valArray(6)
    integer i,j

    if (first .and. new_chains) then
        ! Write(F%Unit) CosmoSettings%TCosmoTheoryParams
        write(*,*) "Tried to write params class to file, which has been disabled for compiler compatibility"
        if (CosmoSettings%use_LSS) call F%WriteSizedArray(CosmoSettings%power_redshifts)
        if (CosmoSettings%use_CMB) call F%WriteSizedArray(CosmoSettings%cl_lmax)
        ArraySizes(1)=size(valArray)
        call F%WriteSizedArray(ArraySizes)
    end if

    write(F%unit) this%numderived
    write(F%unit) this%derived_parameters(1:this%numderived)
    do i=1,CosmoSettings%num_cls
        do j= i, 1, -1
            if (CosmoSettings%cl_lmax(i,j)>0) then
                call F%WriteSizedArray(this%Cls(i,j)%Cl)
            end if
        end do
    end do

    valArray(1:4) = [ this%tensor_ratio_02, this%tensor_ratio_C10, this%tensor_ratio_BB, this%tensor_AT ]
    valArray(5) = this%Lensing_rms_deflect
    valArray(6) = this%sigma_8
    call F%WriteSizedArray(valArray)

    if (CosmoSettings%use_matterpower) then
        write(F%unit) this%MPK%nx, this%MPK%ny
        write(F%unit) this%MPK%x
        write(F%unit) this%MPK%y
        write(F%unit) this%MPK%z
        if(CosmoSettings%use_nonlinear) write(F%unit) this%NL_MPK%z
        if(CosmoSettings%use_WeylPower) write(F%unit) this%MPK_WEYL%z
        if(CosmoSettings%use_nonlinear.and. CosmoSettings%use_WeylPower) write(F%unit) this%NL_MPK_WEYL%z
        if (CosmoSettings%use_sigmaR) call this%sigma_R%SaveState(F)
    end if

    if (CosmoSettings%use_LSS) then
        call this%sigma8_z%SaveState(F)
        call this%growth_z%SaveState(F)
    end if

    end subroutine TCosmoTheoryPredictions_WriteTheory

    subroutine TCosmoTheoryPredictions_AllocateForSettings(this, Settings)
    Class(TCosmoTheoryPredictions) this
    class(TCosmoTheorySettings):: Settings
    integer i,j

    if (allocated(this%Cls)) deallocate(this%Cls)
    allocate(this%Cls(Settings%num_cls,Settings%num_cls))
    do i=1,Settings%num_cls
        do j= i, 1, -1
            if (Settings%cl_lmax(i,j) >0) &
                & allocate(this%Cls(i,j)%Cl(Settings%cl_lmax(i,j)), source=0._mcp)
        end do
    end do
    end subroutine TCosmoTheoryPredictions_AllocateForSettings

    subroutine TCosmoTheoryPredictions_ReadTheory(this, F, first)
    Class(TCosmoTheoryPredictions) this
    class(TFileStream) :: F
    logical, intent(in) :: first
    type(TCosmoTheorySettings), save :: FileSettings
    !JD 02/14 new variables for handling new pk arrays
    integer :: num_k, num_z
    real(mcp), allocatable :: temp(:,:)
    real(mcp), allocatable :: k(:), z(:)
    real(mcp), allocatable :: cl(:)
    real(mcp), allocatable :: valArray(:)
    integer i,j

    if (first) then
        !read(F%Unit) FileSettings%TCosmoTheoryParams
        write(*,*) "Tried to read params class from file, which has been disabled for compiler compatibility"
        if (FileSettings%use_LSS) call F%ReadSizedArray(FileSettings%power_redshifts)
        if (FileSettings%use_CMB) call F%ReadSizedArray(FileSettings%cl_lmax)
        call F%ReadSizedArray(FileSettings%ArraySizes) !not used
    end if

    call this%AllocateForSettings(CosmoSettings)
    this%derived_parameters=0
    read(F%unit) this%numderived
    read(F%unit) this%derived_parameters(1:this%numderived)

    do i=1,FileSettings%num_cls
        do j= i, 1, -1
            if (FileSettings%cl_lmax(i,j)>0) then
                call F%ReadSizedArray(cl)
                if (i> CosmoSettings%num_cls) cycle
                if (CosmoSettings%cl_lmax(i,j)>0) then
                    associate (Sz => min(FileSettings%cl_lmax(i,j),CosmoSettings%cl_lmax(i,j)))
                        this%Cls(i,j)%Cl(1:Sz) = Cl(1:sz)
                    end associate
                end if
                deallocate(cl)
            end if
        end do
    end do

    if (size(FileSettings%ArraySizes)>0) then
        call F%ReadSizedArray(valArray)
        this%tensor_ratio_02 = valArray(1)
        this%tensor_ratio_C10 = valArray(2)
        this%tensor_ratio_BB = valArray(3)
        this%tensor_AT = valArray(4)
        this%Lensing_rms_deflect = valArray(5)
        this%sigma_8 = valArray(6)
    else
        !Old format, can delete at some point
        if (FileSettings%compute_tensors) then
            read(F%unit) this%tensor_ratio_02, this%tensor_ratio_C10, this%tensor_ratio_BB, this%tensor_AT
        end if
        if (FileSettings%get_sigma8 .or. FileSettings%use_LSS) read(F%unit) this%sigma_8
    end if

    if (FileSettings%use_matterpower) then
        if (CosmoSettings%use_matterpower) then
            if (any(FileSettings%power_redshifts/=CosmoSettings%power_redshifts)) &
                & call MpiStop('TCosmoTheoryPredictions_ReadTheory: power_redshifts differ - check')
        end if
        call this%FreePK()
        allocate(this%MPK)
        read(F%unit) num_k, num_z
        allocate(temp(num_k,num_z))
        allocate(k(num_k))
        allocate(z(num_z))
        read(F%unit) k
        read(F%unit) z
        read(F%unit) temp
        call this%MPK%Init(k,z,temp)
        if(FileSettings%use_nonlinear) then
            allocate(this%NL_MPK)
            read(F%unit)temp
            call this%NL_MPK%Init(k,z,temp)
            if(.not. CosmoSettings%use_nonlinear) then
                write(*,*)"WARNING:  ReadTheory - Your data files have nonlinear power spectra,"
                write(*,*)"          but you are not using them. Be careful that this"
                write(*,*)"          is what you intended."
            end if
        end if
        if(FileSettings%use_WeylPower) then
            allocate(this%MPK_WEYL)
            read(F%unit)temp
            call this%MPK_WEYL%Init(k,z,temp)
        end if
        if(FileSettings%use_nonlinear.and. FileSettings%use_WeylPower) then
            allocate(this%NL_MPK_WEYL)
            read(F%unit)temp
            call this%NL_MPK_WEYL%Init(k,z,temp)
        end if

        if (FileSettings%use_sigmaR) then
            if (.not. allocated(this%sigma_R)) allocate(this%Sigma_R)
            call this%sigma_R%LoadState(F)
        end if
    end if

    if (FileSettings%use_LSS) then
        if (.not. allocated(this%growth_z)) allocate(this%growth_z, this%sigma8_z)
        call this%sigma8_z%LoadState(F)
        call this%growth_z%LoadState(F)
    end if

    end subroutine TCosmoTheoryPredictions_ReadTheory

    subroutine TCosmoTheoryPredictions_WriteTextData(this,fnameroot)
    class(TCosmoTheoryPredictions) this
    character(LEN=*), intent(in) :: fnameroot

    if (CosmoSettings%use_CMB) call this%WriteTextCls(fnameroot //'.theory_cl')

    end subroutine TCosmoTheoryPredictions_WriteTextData

    end module CosmoTheory


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

module dart_pop_mod

use        types_mod, only : r4, r8, rad2deg, PI, SECPERDAY, MISSING_R8, digits12
use time_manager_mod, only : time_type, get_date, set_date, get_time, set_time, &
                             set_calendar_type, get_calendar_string, &
                             print_date, print_time, operator(==), operator(-)
use    utilities_mod, only : get_unit, open_file, close_file, file_exist, &
                             register_module, error_handler, &
                             find_namelist_in_file, check_namelist_read, &
                             E_ERR, E_WARN, E_MSG, find_textfile_dims, &
                             logfileunit

use  netcdf_utilities_mod, only : nc_check

use typesizes
use netcdf

implicit none
private

public :: get_pop_calendar, set_model_time_step, &
          get_horiz_grid_dims, get_vert_grid_dim, &
          read_horiz_grid, read_topography, read_vert_grid, &
          write_pop_namelist, get_pop_restart_filename, &
          set_binary_file_conversion, read_mean_dynamic_topography

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

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

logical, save :: module_initialized = .false.

character(len=256) :: ic_filename      = 'pop.r.nc'
!character(len=256) :: restart_filename = 'dart_pop_mod_restart_filename_not_set'

! set this to true if you want to print out the current time
! after each N observations are processed, for benchmarking.
logical :: print_timestamps = .false.
integer :: print_every_Nth  = 10000

! if the binary grid files are big_endian and you are running on
! a little_endian machine, set this string so the convert will
! happen correctly.  options are:  'native', 'big_endian', 'little_endian'

character(len=64) :: conversion = 'native'    ! no conversion

!------------------------------------------------------------------
! The POP time manager namelist variables
!------------------------------------------------------------------

character(len=100) :: accel_file ! length consistent with POP
character(len= 64) :: stop_option, runid, dt_option, time_mix_opt
character(len=  1) :: date_separator
logical  :: impcor, laccel, allow_leapyear
real(r8) :: dtuxcel, dt_count
integer  :: iyear0, imonth0, iday0, ihour0, iminute0, isecond0
integer  :: stop_count, fit_freq, time_mix_freq
real(r8) :: robert_alpha, robert_nu

namelist /time_manager_nml/ runid, time_mix_opt, time_mix_freq, &
    impcor, laccel, accel_file, dtuxcel, iyear0, imonth0, &
    iday0, ihour0, iminute0, isecond0, dt_option, dt_count, &
    stop_option, stop_count, date_separator, allow_leapyear, fit_freq, &
    robert_alpha, robert_nu

!------------------------------------------------------------------
! The POP I/O namelist variables
!------------------------------------------------------------------

character(len=100) :: log_filename, pointer_filename
logical :: lredirect_stdout, luse_pointer_files
logical :: luse_nf_64bit_offset
integer :: num_iotasks

namelist /io_nml/ num_iotasks, lredirect_stdout, log_filename, &
    luse_pointer_files, pointer_filename, luse_nf_64bit_offset

!------------------------------------------------------------------
! The POP restart manager namelist variables
!------------------------------------------------------------------

character(len=100) :: restart_outfile ! length consistent with POP
character(len= 64) :: restart_freq_opt, restart_start_opt, restart_fmt
logical :: leven_odd_on, pressure_correction
integer :: restart_freq, restart_start, even_odd_freq

namelist /restart_nml/ restart_freq_opt, restart_freq, &
     restart_start_opt, restart_start, restart_outfile, &
    restart_fmt, leven_odd_on, even_odd_freq, pressure_correction

!------------------------------------------------------------------
! The POP initial temperature and salinity namelist
!------------------------------------------------------------------

character(len=100) :: init_ts_file ! length consistent with POP
character(len=100) :: init_ts_outfile
character(len= 64) :: init_ts_option, init_ts_suboption
character(len= 64) :: init_ts_file_fmt, init_ts_outfile_fmt
real(r8) :: init_ts_perturb
namelist /init_ts_nml/ init_ts_option, init_ts_suboption, &
                       init_ts_file, init_ts_file_fmt, &
                       init_ts_outfile, init_ts_outfile_fmt, &
                       init_ts_perturb

!------------------------------------------------------------------
! The POP domain namelist
!------------------------------------------------------------------

character(len= 64) :: clinic_distribution_type, tropic_distribution_type
character(len= 64) :: ew_boundary_type, ns_boundary_type
integer :: nprocs_clinic, nprocs_tropic
logical :: profile_barrier

namelist /domain_nml/ clinic_distribution_type, nprocs_clinic, &
                      tropic_distribution_type, nprocs_tropic, &
                      ew_boundary_type, ns_boundary_type, &
                      profile_barrier

!------------------------------------------------------------------
! The POP grid info namelist
!------------------------------------------------------------------
!
! POP grid information comes in several files:
!   horizontal grid lat/lons in one,
!   topography (lowest valid vert level) in another, and
!   the vertical grid spacing in a third.
!
!------------------------------------------------------------------
!
! Here is what we can get from the (binary) horiz grid file:
!   real (r8), dimension(:,:), allocatable :: &
!      ULAT,            &! latitude  (radians) of U points
!      ULON,            &! longitude (radians) of U points
!      HTN ,            &! length (cm) of north edge of T box
!      HTE ,            &! length (cm) of east  edge of T box
!      HUS ,            &! length (cm) of south edge of U box
!      HUW ,            &! length (cm) of west  edge of U box
!      ANGLE             ! angle
!
! Here is what we can get from the topography file:
!   integer, dimension(:,:), allocatable :: &
!      KMT               ! k index of deepest grid cell on T grid
!
! These must be derived or come from someplace else ...
!      KMU               ! k index of deepest grid cell on U grid
!      HT                ! real(r8) value of deepest valid T depth (in cm)
!      HU                ! real(r8) value of deepest valid U depth (in cm)
!
! The vert grid file is ascii, with 3 columns/line:
!    cell thickness(in cm)   cell center(in m)   cell bottom(in m)
!
!------------------------------------------------------------------

character(len=100) :: horiz_grid_file, vert_grid_file, &
                      topography_file, topography_outfile, &
                      bathymetry_file, region_info_file, &
                      bottom_cell_file, region_mask_file
character(len= 64) :: horiz_grid_opt, sfc_layer_opt, vert_grid_opt, &
                      topography_opt
logical :: partial_bottom_cells, topo_smooth, flat_bottom, lremove_points, &
           l1ddyn
integer :: kmt_kmin, n_topo_smooth

namelist /grid_nml/ horiz_grid_opt, horiz_grid_file, sfc_layer_opt, &
    vert_grid_opt, vert_grid_file, topography_opt, kmt_kmin, &
    topography_file, topography_outfile, bathymetry_file, &
    partial_bottom_cells, bottom_cell_file, n_topo_smooth, &
    region_mask_file, topo_smooth, flat_bottom, lremove_points, &
    region_info_file, l1ddyn

!======================================================================
contains
!======================================================================

subroutine initialize_module

integer :: iunit, io

! Read POP calendar information
! In 'restart' mode, this is primarily the calendar type and 'stop'
! information. The time attributes of the restart file override
! the namelist time information.

call find_namelist_in_file('pop_in', 'time_manager_nml', iunit)
read(iunit, nml = time_manager_nml, iostat = io)
call check_namelist_read(iunit, io, 'time_manager_nml')

! FIXME : Real observations are always GREGORIAN dates ...
! but stomping on that here gets in the way of running
! a perfect_model experiment for pre-1601 AD cases.

! STOMP if ( allow_leapyear ) then
   call set_calendar_type('gregorian')
! STOMP else
! STOMP    call set_calendar_type('noleap')
! STOMP endif

! Read POP I/O information (for restart file ... grid dimensions)
! Read POP initial information (for input/restart filename)

call find_namelist_in_file('pop_in', 'io_nml', iunit)
read(iunit, nml = io_nml, iostat = io)
call check_namelist_read(iunit, io, 'io_nml')

call find_namelist_in_file('pop_in', 'init_ts_nml', iunit)
read(iunit, nml = init_ts_nml, iostat = io)
call check_namelist_read(iunit, io, 'init_ts_nml')

! Make sure we have a pop restart file (for grid dims)
if ( .not. file_exist(ic_filename) ) then
   string1 = 'pop_in:init_ts_file '//trim(ic_filename)//' not found'
   call error_handler(E_ERR,'initialize_module', &
          string1, source, revision, revdate)
endif

! Read POP restart information (for model timestepping)
call find_namelist_in_file('pop_in', 'restart_nml', iunit)
read(iunit, nml = restart_nml, iostat = io)
call check_namelist_read(iunit, io, 'restart_nml')

! Read POP domain information (for lon wrapping or not)
call find_namelist_in_file('pop_in', 'domain_nml', iunit)
read(iunit, nml = domain_nml, iostat = io)
call check_namelist_read(iunit, io, 'domain_nml')

! Read POP grid information (for grid filenames)
call find_namelist_in_file('pop_in', 'grid_nml', iunit)
read(iunit, nml = grid_nml, iostat = io)
call check_namelist_read(iunit, io, 'grid_nml')

module_initialized = .true.

! Print module information to log file and stdout.
call register_module(source, revision, revdate)

end subroutine initialize_module

!------------------------------------------------------------------
!> Read the lon, lat grid size from the restart netcdf file.
!> The actual grid file is a binary file with no header information.
!>
!> The file name comes from module storage ... namelist.

subroutine get_horiz_grid_dims(Nx, Ny)

integer, intent(out) :: Nx   ! Number of Longitudes
integer, intent(out) :: Ny   ! Number of Latitudes

integer :: grid_id, dimid, nc_rc

if ( .not. module_initialized ) call initialize_module

! get the ball rolling ...

call nc_check(nf90_open(trim(ic_filename), nf90_nowrite, grid_id), &
         'get_horiz_grid_dims','open '//trim(ic_filename))

! Longitudes : get dimid for 'i' or 'nlon', and then get value
nc_rc = nf90_inq_dimid(grid_id, 'i', dimid)
if (nc_rc /= nf90_noerr) then
   nc_rc = nf90_inq_dimid(grid_id, 'nlon', dimid)
   if (nc_rc /= nf90_noerr) then
      string1 = "unable to find either 'i' or 'nlon' in file "//trim(ic_filename)
      call error_handler(E_ERR, 'get_horiz_grid_dims', string1, &
                         source,revision,revdate)
   endif
endif

call nc_check(nf90_inquire_dimension(grid_id, dimid, len=Nx), &
         'get_horiz_grid_dims','inquire_dimension i '//trim(ic_filename))

! Latitudes : get dimid for 'j' or 'nlat' ... and then get value
nc_rc = nf90_inq_dimid(grid_id, 'j', dimid)
if (nc_rc /= nf90_noerr) then
   nc_rc = nf90_inq_dimid(grid_id, 'nlat', dimid)
   if (nc_rc /= nf90_noerr) then
      string1 = "unable to find either 'j' or 'nlat' in "//trim(ic_filename)
      call error_handler(E_ERR, 'get_horiz_grid_dims', string1, &
                         source,revision,revdate)
   endif
endif

call nc_check(nf90_inquire_dimension(grid_id, dimid, len=Ny), &
         'get_horiz_grid_dims','inquire_dimension i '//trim(ic_filename))

! tidy up

call nc_check(nf90_close(grid_id), &
         'get_horiz_grid_dims','close '//trim(ic_filename) )

end subroutine get_horiz_grid_dims

!------------------------------------------------------------------
!> count the number of lines in the ascii file to figure out max
!> number of vert blocks.

subroutine get_vert_grid_dim(Nz)

integer, intent(out) :: Nz

integer :: linelen ! disposable

if ( .not. module_initialized ) call initialize_module

call find_textfile_dims(vert_grid_file, Nz, linelen)

end subroutine get_vert_grid_dim

!------------------------------------------------------------------
!> the initialize_module ensures that the pop namelists are read and
!> the DART time manager gets the pop calendar setting.
!>
!> Then, the DART time manager is queried to return what it knows ...

subroutine get_pop_calendar(calstring)

character(len=*), INTENT(OUT) :: calstring

if ( .not. module_initialized ) call initialize_module

call get_calendar_string(calstring)

end subroutine get_pop_calendar

!------------------------------------------------------------------
!> the initialize_module ensures that the pop namelists are read.
!> The restart times in the pop_in&restart_nml are used to define
!> appropriate assimilation timesteps.

function set_model_time_step(seconds,days)

integer, intent(in) :: seconds ! input.nml assimilation_period_seconds
integer, intent(in) :: days    ! input.nml assimilation_period_days
type(time_type) :: set_model_time_step

if ( .not. module_initialized ) call initialize_module

! Check to see if the input.nml:&model_nml:assimilation_period_[seconds,days]
! are specifying the nominal model output frequency/assimilation interval.

if (seconds <= 0 .and. days <= 0) then

   ! Check the 'restart_freq_opt' and 'restart_freq' to determine
   ! when we can stop the model

   if ( trim(restart_freq_opt) == 'nday' ) then
      set_model_time_step = set_time(0, restart_freq) ! (seconds, days)
   else if ( trim(restart_freq_opt) == 'nyear' ) then
      ! FIXME ... CCSM_POP uses a bogus value for this
      set_model_time_step = set_time(0, 1) ! (seconds, days)
      write(string1,*)'WARNING: POP namelist variable "restart_freq_opt" read as "nyear"'
      write(string2,*)'CESM uses bogus value - using default value of 1 day.'
      call error_handler(E_MSG,'set_model_time_step', string1, &
                 source, revision, revdate, text2=string2)
   else
      write(string1,*)'POP namelist variable "restart_freq_opt" must be "nday" or "nyear"'
      write(string2,*)'read as "'//trim(restart_freq_opt)//'"'
      call error_handler(E_ERR,'set_model_time_step', string1, &
                 source, revision, revdate, text2=string2)
   endif

elseif (seconds < 0 .or. days < 0) then
   write(string1,*)'Unable to determine the assimilation interval.'
   write(string2,*)'input.nml:&model_nml:assimilation_period_seconds must be >= 0; is ',seconds
   write(string3,*)'input.nml:&model_nml:assimilation_period_days    must be >= 0; is ',days
   call error_handler(E_ERR,'set_model_time_step', string1, &
              source, revision, revdate, text2=string2, text3=string3)
else
   set_model_time_step = set_time(seconds, days) ! (seconds, days)
endif

end function set_model_time_step

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

subroutine write_pop_namelist(model_time, adv_to_time)

type(time_type), INTENT(IN) :: model_time, adv_to_time
type(time_type) :: offset

integer :: iunit, secs, days

if ( .not. module_initialized ) call initialize_module

offset = adv_to_time - model_time
call get_time(offset, secs, days)

if (secs /= 0 ) then
   write(string1,*)'adv_to_time has seconds == ',secs,' must be zero'
   call error_handler(E_ERR,'write_pop_namelist', string1, source, revision, revdate)
endif

! call print_date( model_time,'write_pop_namelist:dart model date')
! call print_date(adv_to_time,'write_pop_namelist:advance_to date')
! call print_time( model_time,'write_pop_namelist:dart model time')
! call print_time(adv_to_time,'write_pop_namelist:advance_to time')
! call print_time(     offset,'write_pop_namelist:a distance of')
! write( *,'(''write_pop_namelist:TIME_MANAGER_NML   STOP_COUNT '',i10,'' days'')') days

!Convey the information to the namelist 'stop option' and 'stop count'

if ( trim(stop_option) == 'nday' ) then
   stop_count = days
elseif ( trim(stop_option) == 'nyear' ) then
   if (days > 365) then
      stop_count = days/365   ! relying on integer arithmetic
   else
      ! CESM totally ignores this value
      write(string1,*)'POP time_manager_nml:stop_option,stop_count are ',trim(stop_option),stop_count
      write(string2,*)'DART wants to advance ',days,' "days"'
      write(string3,*)'Unable to reconcile; using original stop_option,stop_count.'
      call error_handler(E_WARN,'write_pop_namelist', string1, &
                 source, revision, revdate, text2=string2)
      continue
   endif
else
   call error_handler(E_ERR,'write_pop_namelist', &
              'stop_option must be "nday" or "nyear"', source, revision, revdate)
endif

iunit = open_file('pop_in.DART',form='formatted',action='rewind')
write(iunit, nml=time_manager_nml)
write(iunit, '('' '')')
close(iunit)

end subroutine write_pop_namelist

!------------------------------------------------------------------
!> Open and read the binary grid file

subroutine read_horiz_grid(nx, ny, ULAT, ULON, TLAT, TLON)

integer,                    intent(in)  :: nx, ny
real(r8), dimension(nx,ny), intent(out) :: ULAT, ULON, TLAT, TLON

!real(r8), dimension(nx,ny) :: &
!     HTN ,  &! length (cm) of north edge of T box
!     HTE ,  &! length (cm) of east  edge of T box
!     HUS ,  &! length (cm) of south edge of U box
!     HUW ,  &! length (cm) of west  edge of U box
!     ANGLE  ! angle

integer :: grid_unit, reclength
real(digits12), dimension(nx,ny) :: ULAT64, ULON64

if ( .not. module_initialized ) call initialize_module

! Check to see that the file exists.

if ( .not. file_exist(horiz_grid_file) ) then
   string1 = 'pop_in:horiz_grid_file '//trim(horiz_grid_file)//' not found'
   call error_handler(E_ERR,'read_horiz_grid', &
          string1, source, revision, revdate)
endif

! Open it and read them in the EXPECTED order.
! Actually, we only need the first two, so I'm skipping the rest.

grid_unit = get_unit()
INQUIRE(iolength=reclength) ULAT64

open(grid_unit, file=trim(horiz_grid_file), form='unformatted', convert=conversion, &
            access='direct', recl=reclength, status='old', action='read' )
read(grid_unit, rec=1) ULAT64
read(grid_unit, rec=2) ULON64
!read(grid_unit, rec=3) HTN
!read(grid_unit, rec=4) HTE
!read(grid_unit, rec=5) HUS
!read(grid_unit, rec=6) HUW
!read(grid_unit, rec=7) ANGLE
close(grid_unit)

ULAT = ULAT64
ULON = ULON64

call calc_tpoints(nx, ny, ULAT, ULON, TLAT, TLON)

! convert from radians to degrees

ULAT = ULAT * rad2deg
ULON = ULON * rad2deg
TLAT = TLAT * rad2deg
TLON = TLON * rad2deg

! ensure [0,360) [-90,90]

where (ULON <   0.0_r8) ULON = ULON + 360.0_r8
where (ULON > 360.0_r8) ULON = ULON - 360.0_r8
where (TLON <   0.0_r8) TLON = TLON + 360.0_r8
where (TLON > 360.0_r8) TLON = TLON - 360.0_r8

where (ULAT < -90.0_r8) ULAT = -90.0_r8
where (ULAT >  90.0_r8) ULAT =  90.0_r8
where (TLAT < -90.0_r8) TLAT = -90.0_r8
where (TLAT >  90.0_r8) TLAT =  90.0_r8

end subroutine read_horiz_grid

!------------------------------------------------------------------
!> mimic POP grid.F90:calc_tpoints(), but for one big block.

subroutine calc_tpoints(nx, ny, ULAT, ULON, TLAT, TLON)

integer,                    intent( in) :: nx, ny
real(r8), dimension(nx,ny), intent( in) :: ULAT, ULON
real(r8), dimension(nx,ny), intent(out) :: TLAT, TLON

integer  :: i, j
real(r8) :: xc,yc,zc,xs,ys,zs,xw,yw,zw   ! Cartesian coordinates for
real(r8) :: xsw,ysw,zsw,tx,ty,tz,da      ! nbr points

real(r8), parameter ::  c0 = 0.000_r8, c1 = 1.000_r8
real(r8), parameter ::  c2 = 2.000_r8, c4 = 4.000_r8
real(r8), parameter :: p25 = 0.250_r8, p5 = 0.500_r8
real(r8)            :: pi, pi2, pih, radian

if ( .not. module_initialized ) call initialize_module

! Define some constants as in pop

pi     = c4*atan(c1)
pi2    = c2*pi
pih    = p5*pi
radian = 180.0_r8/pi

! initialize these arrays to 0. in the code below there is
! a column that is referenced by a where() construct before
! those values are set.  make sure that it doesn't cause a
! floating point exception from random memory bits which aren't
! valid floating point numbers.
TLAT(:,:) = c0
TLON(:,:) = c0

do j=2,ny
do i=2,nx

   !*** convert neighbor U-cell coordinates to 3-d Cartesian coordinates
   !*** to prevent problems with averaging near the pole

   zsw = cos(ULAT(i-1,j-1))
   xsw = cos(ULON(i-1,j-1))*zsw
   ysw = sin(ULON(i-1,j-1))*zsw
   zsw = sin(ULAT(i-1,j-1))

   zs  = cos(ULAT(i  ,j-1))
   xs  = cos(ULON(i  ,j-1))*zs
   ys  = sin(ULON(i  ,j-1))*zs
   zs  = sin(ULAT(i  ,j-1))

   zw  = cos(ULAT(i-1,j  ))
   xw  = cos(ULON(i-1,j  ))*zw
   yw  = sin(ULON(i-1,j  ))*zw
   zw  = sin(ULAT(i-1,j  ))

   zc  = cos(ULAT(i  ,j  ))
   xc  = cos(ULON(i  ,j  ))*zc
   yc  = sin(ULON(i  ,j  ))*zc
   zc  = sin(ULAT(i  ,j  ))

   !*** straight 4-point average to T-cell Cartesian coords

   tx = p25*(xc + xs + xw + xsw)
   ty = p25*(yc + ys + yw + ysw)
   tz = p25*(zc + zs + zw + zsw)

   !*** convert to lat/lon in radians

   da = sqrt(tx**2 + ty**2 + tz**2)

   TLAT(i,j) = asin(tz/da)

   if (tx /= c0 .or. ty /= c0) then
      TLON(i,j) = atan2(ty,tx)
   else
      TLON(i,j) = c0
   endif

end do
end do

!*** for bottom row of domain where sw 4pt average is not valid,
!*** extrapolate from interior
!*** NOTE: THIS ASSUMES A CLOSED SOUTH BOUNDARY - WILL NOT
!***       WORK CORRECTLY FOR CYCLIC OPTION

do i=1,nx
   TLON(i,1) =    TLON(i,1+1)
   TLAT(i,1) = c2*TLAT(i,1+1) - TLAT(i,1+2)
end do

where (TLON(:,:) > pi2) TLON(:,:) = TLON(:,:) - pi2
where (TLON(:,:) < c0 ) TLON(:,:) = TLON(:,:) + pi2

!*** this leaves the leftmost/western edge to be filled
!*** if the longitudes wrap, this is easy.
!*** the gx3v5 grid TLON(:,2) and TLON(:,nx) are both about 2pi,
!*** so taking the average is reasonable.
!*** averaging the latitudes is always reasonable.

if ( trim(ew_boundary_type) == 'cyclic' ) then

   TLAT(1,:) = (TLAT(2,:) + TLAT(nx,:))/c2
   TLON(1,:) = (TLON(2,:) + TLON(nx,:))/c2

else
   write(string1,'(''pop_in&domain_nml:ew_boundary_type '',a,'' unknown.'')') &
                                    trim(ew_boundary_type)
   call error_handler(E_ERR,'calc_tpoints',string1,source,revision,revdate)
endif

end subroutine calc_tpoints

!------------------------------------------------------------------
!> Open and read the binary topography file

subroutine read_topography(nx, ny, KMT, KMU)

integer,                   intent(in)  :: nx, ny
integer, dimension(nx,ny), intent(out) :: KMT, KMU

integer  :: i, j, topo_unit, reclength

if ( .not. module_initialized ) call initialize_module

! Check to see that the file exists.

if ( .not. file_exist(topography_file) ) then
   string1 = 'pop_in:topography_file '//trim(topography_file)//' not found'
   call error_handler(E_ERR,'read_topography', &
          string1, source, revision, revdate)
endif

! read the binary file

topo_unit = get_unit()
INQUIRE(iolength=reclength) KMT

open( topo_unit, file=trim(topography_file), form='unformatted', convert=conversion, &
            access='direct', recl=reclength, status='old', action='read' )
read( topo_unit, rec=1) KMT
close(topo_unit)

! the equation numbered 3.2 on page 15 of this document:
!  http://www.cesm.ucar.edu/models/cesm1.0/pop2/doc/sci/POPRefManual.pdf
! is WRONG.  (WRONG == inconsistent with the current POP source code.)
!
! for any U(i,j), the T(i,j) point with the same index values is located
! south and west. so the T points which surround any U(i,j) point are
! in fact at indices i,i+1, and j,j+1 .
!
!  NO: KMU(i,j) = min(KMT(i, j), KMT(i-1, j), KMT(i, j-1), KMT(i-1, j-1))
! YES: KMU(i,j) = min(KMT(i, j), KMT(i+1, j), KMT(i, j+1), KMT(i+1, j+1))
!
! the latter matches the POP source code, on yellowstone, lines 908 and 909 in:
!  /glade/p/cesm/releases/cesm1_2_2/models/ocn/pop2/source/grid.F90
!
! wrap around longitude boundary at i == nx.  set the topmost (last) latitude
! U row to the same value in all cases. in the shifted pole grid currently in
! use all these points are on land and so are 0.  in the original unshifted
! lat/lon grid these last row U points are above the final T row and are believed
! to be unused.  for completeness we set all values in the last U row to the
! minimum of the all T row values immediately below it, for all longitudes.

do j=1,ny-1
   do i=1,nx-1
      KMU(i,j) = min(KMT(i, j), KMT(i+1, j), KMT(i, j+1), KMT(i+1, j+1))
   enddo
   KMU(nx,j) = min(KMT(nx, j), KMT(1, j), KMT(nx, j+1), KMT(1, j+1))
enddo
KMU(:,ny) = minval(KMT(:,ny))

end subroutine read_topography

!------------------------------------------------------------------
!> Open and read the ASCII vertical grid information

subroutine read_vert_grid(nz, ZC, ZG)

! The vert grid file is in ascii, with either 3 columns/line
!    cell thickness(in cm)   cell center(in m)   cell bottom(in m)
! or it can contain 2 columns/line
!    cell thickness(in cm)   1.0
! in which case we compute the cell center (ZC) and cell bottom (ZG)
! and ignore the second column.

integer,  intent(in)  :: nz
real(r8), intent(out) :: ZC(nz), ZG(nz)

integer  :: iunit, i, ios
real(r8) :: depth

logical :: three_columns
character(len=256) :: line

real(r8), parameter :: centimeters_to_meters = 0.01_r8

if ( .not. module_initialized ) call initialize_module

! Check to see that the file exists.

if ( .not. file_exist(vert_grid_file) ) then
   string1 = 'pop_in:vert_grid_file '//trim(vert_grid_file)//' not found'
   call error_handler(E_ERR,'read_vert_grid', &
          string1, source, revision, revdate)
endif

! read the ASCII file

iunit = open_file(trim(vert_grid_file), action = 'read')

! determine the number of columns
read(iunit,'(A)') line

read(line,*,iostat=ios) depth, ZC(1), ZG(1)

if(ios == 0) then
   three_columns = .true.
else
   three_columns = .false.

   ! read depth and calculate center and bottom of cells
   read(line,*,iostat=ios) depth

   ZC(1) = depth*centimeters_to_meters*0.5_r8
   ZG(1) = depth*centimeters_to_meters
endif

do i=2, nz

   if(three_columns) then
      read(iunit,*,iostat=ios) depth, ZC(i), ZG(i)
   else
      read(iunit,*,iostat=ios) depth

      ZC(i) = ZG(i-1) + depth*centimeters_to_meters*0.5_r8
      ZG(i) = ZG(i-1) + depth*centimeters_to_meters
   endif

   if ( ios /= 0 ) then ! error
      write(string1,*)'error reading depths, line ',i
      call error_handler(E_ERR,'read_vert_grid',string1,source,revision,revdate)
   endif

enddo

end subroutine read_vert_grid

!------------------------------------------------------------------
!> Open and read the mean dynamic sea surface topography
!> There is an assumed name and the shape of the variable must
!> match the POP grid being used. The hope is that that actual
!> locations MUST MATCH EXACTLY the POP SSH grid.

subroutine read_mean_dynamic_topography(fname, mdt)
character(len=*), intent(in)  :: fname
real(r8),         intent(out) :: mdt(:,:)

integer  :: ncid, VarID, io, xtype, ii
integer  :: numdims, dimIDs(NF90_MAX_DIMS), dimlen
character(len=128) :: unitsstring
real(r4) :: rmiss
real(r8) :: dmiss, dmin, dmax

if ( .not. module_initialized ) call initialize_module

mdt = MISSING_R8
dmiss = MISSING_R8

! Check to see that the netCDF file exists.

if ( .not. file_exist(fname) ) then
   string1 = 'Mean dynamic sea surface topography file not found.'
   string2 = 'Looking for filename "'//trim(fname)//'"'
   string3 = 'This filename is specified by input.nml:model_nml:mdt_reference_file_name'
   call error_handler(E_ERR,'read_mean_dynamic_topography', &
          string1, source, revision, revdate, text2=string2, text3=string3)
endif

io = nf90_open(trim(fname), NF90_NOWRITE, ncid)
call nc_check(io, 'read_mean_dynamic_topography','open "'//trim(fname)//'"')

io = nf90_inq_varid(ncid, 'mdt', VarID)
call nc_check(io, 'read_mean_dynamic_topography', &
                  '"mdt" not found but is required in "'//trim(fname)//'"')

! check variable shape against assumed shape

io = nf90_inquire_variable(ncid, VarId, dimids=dimIDs, ndims=numdims, xtype=xtype)
call nc_check(io, 'read_mean_dynamic_topography', &
                  'inquire_variable "mdt" from "'//trim(fname)//'"')

do ii = 1,numdims
   write(string1,*)'inquire_dimension ',ii,'for "mdt"'
   io = nf90_inquire_dimension(ncid,dimIDs(ii),len=dimlen)
   call nc_check(io, 'read_mean_dynamic_topography', string1)

   if (dimlen /= size(mdt,ii)) then
      write(string1,*)'mdt dimension mismatch'
      write(string2,*)'mdt dimension ',ii,' in file is ',dimlen
      write(string3,*)'mdt dimension ',ii,' in code is ',size(mdt,ii)
      call error_handler(E_ERR,'read_mean_dynamic_topography', &
          string1, source, revision, revdate, text2=string2, text3=string3)
   endif

enddo

io = nf90_get_var(ncid, VarID, mdt)
call nc_check(io, 'read_mean_dynamic_topography', &
                  'get_var "mdt" from "'//trim(fname)//'"')

! Replace _FillValue with something
!>@todo CHECK ... does it xtype of the variable matter when getting a _FillValue attribute.
!> If it does not, these lines could collapse into something cleaner.

if (xtype == NF90_REAL) then
   io = nf90_get_att(ncid, VarId, '_FillValue', rmiss)
   if (io == NF90_NOERR) then
      dmiss=rmiss
      where (mdt == dmiss) mdt = MISSING_R8
   endif
elseif (xtype == NF90_DOUBLE) then
   io = nf90_get_att(ncid, VarId, '_FillValue', dmiss)
   if (io == NF90_NOERR) then
      where (mdt == dmiss) mdt = MISSING_R8
   endif
else
   call error_handler(E_ERR,'read_mean_dynamic_topography', &
        'unsupported variable type for "mdt"', source, revision, revdate, &
        text2 = 'must be "float" or "double"')
endif

! The observations are in meters, the mean dynamic topography should be in meters
! and internally in the POP model_mod, the CGS units are converted to SI.

io = nf90_get_att(ncid, VarId, 'units', unitsstring)
call nc_check(io, 'read_mean_dynamic_topography', &
                  'get_att "units" for "mdt" from "'//trim(fname)//'"')

if (unitsstring == 'centimeter' .or. unitsstring == 'cm') then
   where(mdt /= MISSING_R8) mdt = mdt/100.0_r8
elseif (unitsstring == 'm' .or. unitsstring == 'meters') then
   continue
else
   call error_handler(E_ERR,'read_mean_dynamic_topography', &
        'unsupported units for "mdt"', source, revision, revdate, &
        text2 = 'must be "centimeter", "cm", "meter", or "m"')
endif

call nc_check(nf90_close(ncid), &
              'read_mean_dynamic_topography','close ' // trim(fname) )

! Just something to do a basic check.

dmin = minval(mdt, mdt /= MISSING_R8)
dmax = maxval(mdt, mdt /= MISSING_R8)
write(string1,*)'..  mdt sizes are ',size(mdt,1),size(mdt,2)
write(string2,*)'_FillValue was ',dmiss,' original units "'//trim(unitsstring)//'"'
write(string3,*)'min,max (meters) ',dmin, dmax
call error_handler(E_MSG,'read_mean_dynamic_topography', &
     string1, text2=string2, text3=string3)

end subroutine read_mean_dynamic_topography

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

subroutine get_pop_restart_filename( filename )

character(len=*), intent(out) :: filename

if ( .not. module_initialized ) call initialize_module

filename   = trim(ic_filename)

end subroutine get_pop_restart_filename

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

subroutine set_binary_file_conversion(convertstring)

character(len=*), intent(in) :: convertstring

if ( .not. module_initialized ) call initialize_module

conversion = convertstring

end subroutine set_binary_file_conversion

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

end module dart_pop_mod