w3gsrumd.F90

Go to the documentation of this file.

!/ =================================================================== /
!/ Define the ENABLE_WW3 macro when compiling within Wavewatch III.
!/
!/ When compiling outside of Wavewatch III the ENABLE_WW3 must be
!/ undefined and the ENABLE_MPI macro must be defined if compiling
!/ with MPI.
!/ =================================================================== /
#define ENABLE_WW3
 
 
 
 
#ifdef ENABLE_WW3
#include "w3macros.h"
#endif
!/ =================================================================== /
MODULE w3gsrumd
  !/
  !/                  +-----------------------------------+
  !/                  | WAVEWATCH III           NOAA/NCEP |
  !/                  |        T. J. Campbell, NRL        |
  !/                  |                        FORTRAN 90 |
  !/                  | Last update :         25-Jan-2017 |
  !/                  +-----------------------------------+
  !/
  !/    30-Oct-2009 : Origination.                        ( version 3.14 )
  !/    14-Jun-2010 : Fix for ACOS argument > 1 in W3DIST ( version 3.14 )
  !/    12-Nov-2010 : Change T_NNS, W3NN*, W3SORT, W3ISRT to public.
  !/                  Add W3GFIJ (public). Implement r4 & r8 interfaces.
  !/                  Add subcell check for grid cell that includes a pole.
  !/                  Change to number of search buckets based on
  !/                  dimensions of input grid.           ( version 3.14 )
  !/    01-Dec-2010 : Assign cells to buckets based on overlap. The
  !/                  nearest-neighbor bucket search is removed (no longer
  !/                  needed). Add support for tripole grids (JCLO).
  !/                  Add W3GFCD (public). Some cleanup. Add ouput of
  !/                  approximate memory usage.           ( version 3.14 )
  !/    01-Dec-2010 : Add check for target point coincident with a cell
  !/                  vertex in W3RMBL.  Change to error exit when unable
  !/                  to determine local (i,j).           ( version 3.14 )
  !/    06-Dec-2010 : Remove restriction on longitude range. Change ICLO
  !/                  to integer and remove JCLO. Implement support for
  !/                  r4 and r8 source grids.             ( version 3.14 )
  !/    15-Jun-2012 : Fixed various format statements that gave compile
  !/                  warnings with Intel compiler on NCEP R&D machine
  !/                  zeus (H. L. Tolman)                 ( version 4.07 )
  !/    20-Jan-2017 : Moved all record of changes from subroutines to
  !/                  the top of the module and consolidate source code
  !/                  for procedure interfaces            ( version 6.02 )
  !/    20-Jan-2017 : Generalize index bounds for source  ( version 6.02 )
  !/    20-Jan-2017 : Fix tripole grid index mapping and implement
  !/                  additional index closure types.     ( version 6.02 )
  !/    20-Jan-2017 : Add small non-zero tolerance to bounding box checks,
  !/                  point coincidence checks and checks for points that
  !/                  lie exactly on a cell side          ( version 6.02 )
  !/    20-Jan-2017 : Add option to W3GFCL, W3GRMP, W3GFPT, and W3GFIJ to
  !/                  allow target outside of source grid ( version 6.02 )
  !/    20-Jan-2017 : Implement more accurate sin(d/2) equation in W3DIST
  !/                  for computing angular distance      ( version 6.02 )
  !/    20-Jan-2017 : Implement stereographic projection for remapping
  !/                  from cells near a pole              ( version 6.02 )
  !/    20-Jan-2017 : Add routine for computing metric and derivatives
  !/                  for a curvilinear grid and routines for computing
  !/                  gradient and divergence of fields defined on a
  !/                  curvilinear grid                    ( version 6.02 )
  !/    20-Jan-2017 : Add routine for computing computing bounding box
  !/                  for a curvilinear grid              ( version 6.02 )
  !/    20-Jan-2017 : Add W3GRMC as generic routine for computing
  !/                  remapping coefficients              ( version 6.02 )
  !/    25-Jan-2017 : Fix index offsets for MASK in W3GRMP and W3GRMC.
  !/                  Change redist to nearpt in W3GRMC.  ( version 6.03 )
  !/    31-Oct-2017 : Add optional MASK input for W3CGDM. ( version 6.03 )
  !/    18-Jul-2018 : Add fall back to NFD = 2 in W3CGDM for metric
  !/                  calculations where GSQRL < 0.       ( version 6.05 )
  !/
  !  1. Purpose :
  !
  !     Search, regrid, and miscellaneous utilities (data structures and
  !     associated methods) for logically rectangular grids.
  !
  !     The grid-search-utility (GSU) object can be used for rapid searching
  !     of the associated grid to identify a grid cell that encloses a target
  !     point and to compute interpolation weights.  The GSU object maintains
  !     internal pointers to the associated grid coordinate arrays.  Rapid
  !     searching is done using a bucket search algorithm.  The search buckets
  !     are based on the bounding box for the associated grid and an optional
  !     user defined approximate number of grid cells per search bucket.
  !
  !     Grid cells are identified by the cell's lower-left corner grid point.
  !     The vertices (grid points) associated with a grid cell are assigned a
  !     sequential index in a counterclockwise order beginning with the cell's
  !     lower-left corner grid point.  That is, when moving from vertex 1 to
  !     vertex 2 to vertex 3, etc., the grid cell interior is always to the left.
  !     Note that though cell will be counterclockwise w.r.t. indices, this does
  !     not necessarily mean that the cell will be counterclockwise geographically,
  !     specifically in situation of curvilinear grid.
  !
  !                  (x4,y4)               (x3,y3)
  !                      _____________________
  !                     /                    /
  !                    /                    /
  !                   /                    /
  !                  /                    /
  !                 /____________________/
  !             (x1,y1)              (x2,y2)
  !
  !
  !     A simple interpolation example:
  !
  !          -----------------------------------------------------------
  !          ! Define data
  !          TYPE(T_GSU) :: GSU
  !          LOGICAL :: IJG  = .TRUE.
  !          LOGICAL :: LLG  = .TRUE.
  !          LOGICAL :: ICLO = ICLO_NONE
  !          REAL, POINTER :: XS(:,:), YS(:,:)  !source grid coordinates
  !          REAL :: FS(:,:)                    !source field
  !          INTEGER :: NT                      !number of target points
  !          REAL :: XT(NT), YT(NT), FT(NT)     !target coordinates and field
  !          INTEGER :: IS(4), JS(4)            !interpolation points
  !          REAL :: RW(4)                      !interpolation weights
  !
  !          ! Setup source grid and field and target points
  !          < ... >
  !
  !          ! Create grid-search-utility object for source grid
  !          GSU = W3GSUC( IJG, LLG, ICLO, XS, YS )
  !
  !          ! Interpolate source field to target points
  !          DO K=1,NT
  !            FT(K) = 0
  !            IF ( W3GRMP( GSU, XT(K), YT(K), IS, JS, RW ) ) THEN
  !                DO L=1,4
  !                  FT(K) = FT(K) + RW(L)*FS(IS(L),JS(L))
  !                  END DO
  !              END IF
  !            END DO
  !
  !          ! Destroy grid-search-utility object
  !          CALL W3GSUD( GSU )
  !          -----------------------------------------------------------
  !
  !  2. Variables and types :
  !
  !     All module variables and types are scoped private by default.
  !     The private module variables and types are not listed in this section.
  !
  !      Name      Type  Scope    Description
  !     ----------------------------------------------------------------
  !      MSKC_NONE I.P.  Public   Named constant identifying a non-masked
  !                               enclosing grid cell
  !      MSKC_PART I.P.  Public   Named constant identifying a partially
  !                               masked enclosing grid cell
  !      MSKC_FULL I.P.  Public   Named constant identifying a fully
  !                               masked enclosing grid cell
  !      ICLO_NONE I.P.  Public   Named constant identifying a grid with
  !                               no closure in index space
  !      ICLO_SMPL I.P.  Public   Synonym for ICLO_GRDI
  !      ICLO_GRDI I.P.  Public   Named constant identifying a grid with
  !                               closure in I-index: (UBX+1, j) => (LBX, j)
  !      ICLO_GRDJ I.P.  Public   Named constant identifying a grid with
  !                               closure in J-index: (i, UBY+1) => (i, LBY)
  !      ICLO_TRDL I.P.  Public   Named constant identifying a grid with
  !                               toroidal closure: (UBX+1, j) => (LBX, j) and
  !                                                 (i, UBY+1) => (i, LBY)
  !      ICLO_TRPL I.P.  Public   Named constant identifying a grid with
  !                               tripole closure: (UBX+1, LBY<=j<=UBY) => (LBX, j)
  !                               and (LBX<=i<=UBX, UBY+1) => (UBX+LBX-i, UBY)
  !      T_GSU     TYPE  Public   Grid-search-utility type (opaque)
  !      T_NNS     TYPE  Public   Nearest-neighbor grid-point search type
  !     ----------------------------------------------------------------
  !
  !  3. Subroutines and functions :
  !
  !     All module subroutines and functions are scoped private by default.
  !
  !      Name      Type  Scope    Description
  !     ----------------------------------------------------------------
  !      W3GSUC    Func. Public   Create grid-search-utility object.
  !      W3GSUD    Subr. Public   Destroy grid-search-utility object.
  !      W3GSUP    Subr. Public   Print grid-search-utility object to stdout.
  !      W3BBOX    Subr. Public   Get bounding box associated with grid.
  !      W3GFCL    Func. Public   Find grid cell that encloses target point (bucket search).
  !      W3GFCD    Func. Public   Find grid cell that encloses target point (direct search).
  !      W3GFPT    Func. Public   Find grid point that is closest to target point.
  !      W3GFIJ    Func. Public   Compute coord of target point in source grid index space
  !      W3GRMP    Func. Public   Compute bilinear interpolation coeff. from grid.
  !      W3GRMC    Func. Public   Compute remapping coeff. from grid.
  !      W3CKCL    Func. Public   Check if point lies within grid cell.
  !      W3CGDM    Func. Public   Compute curvilinear grid derivatives and metric
  !      W3GRD0    Func. Public   Compute gradient of scalar field
  !      W3DIV1    Func. Public   Compute divergence of a vector field
  !      W3DIV2    Func. Public   Compute divergence of a tensor field
  !      W3DIST    Func. Public   Compute distance between two points.
  !      W3SPLX    Func. Public   Compute Cartesian coord using stereographic projection
  !      W3SPXL    Func. Public   Compute (lon,lat) coord using stereographic projection
  !      W3TRLL    Func. Public   Compute (lon,lat) in rotated coordinate system
  !      W3LLAZ    Func. Public   Compute azimuth for pair of (lon,lat) points
  !      W3FDWT    Func. Public   Compute finite-difference weights.
  !      W3NNSC    Func. Public   Create nearest-neighbor-search object.
  !      W3NNSD    Subr. Public   Destroy nearest-neighbor-search object.
  !      W3NNSP    Subr. Public   Print nearest-neighbor-search object to stdout.
  !      W3SORT    Subr. Public   Sort input arrays in increasing order.
  !      W3ISRT    Subr. Public   Insert data into array.
  !      W3INAN    Func. Public   Check if input is infinite or NaN.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines and functions used :
  !
  !      Name      Type  Module   Description
  !     ----------------------------------------------------------------
  !      STRACE    Subr. W3SERVMD Subroutine tracing.
  !      EXTCDE    Subr. W3SERVMD Abort program with exit code.
  !     ----------------------------------------------------------------
  !
  !  5. Remarks :
  !
  !     - The GSU object is an "opaque" object.  This means that the
  !       internals of the object are not accessible outside this module.
  !     - The burden is upon the user to invoke the destroy method when
  !       finished with a GSU object.  If created GSU objects are
  !       not properly destroyed, then memory leaks may be introduced.
  !
  !  6. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  !  7. Source code :
  !
  !/ =================================================================== /
  !/
  !/ Use associated modules
  !/
#ifdef ENABLE_WW3
  USE w3servmd, ONLY: extcde
#endif
#ifdef W3_S
  USE w3servmd, ONLY: strace
#endif
  !/
  !/ Specify default data typing
  !/
  IMPLICIT NONE
  !/
  !/ Specify default accessibility
  !/
  PRIVATE
  !/
  !/ Public module methods
  !/
  PUBLIC w3gsuc
  PUBLIC w3gsud
  PUBLIC w3gsup
  PUBLIC w3bbox
  PUBLIC w3gfcl
  PUBLIC w3gfcd
  PUBLIC w3gfpt
  PUBLIC w3gfij
  PUBLIC w3grmp
  PUBLIC w3grmc
  PUBLIC w3ckcl
  PUBLIC w3cgdm
  PUBLIC w3grd0
  PUBLIC w3div1
  PUBLIC w3div2
  PUBLIC w3dist
  PUBLIC w3splx
  PUBLIC w3spxl
  PUBLIC w3trll
  PUBLIC w3llaz
  PUBLIC w3fdwt
  PUBLIC w3nnsc
  PUBLIC w3nnsd
  PUBLIC w3nnsp
  PUBLIC w3sort
  PUBLIC w3isrt
  PUBLIC w3inan
  !/
  !/ Public return codes
  !/
  INTEGER, PARAMETER, PUBLIC :: mskc_none = 0
  INTEGER, PARAMETER, PUBLIC :: mskc_part = 1
  INTEGER, PARAMETER, PUBLIC :: mskc_full = 2
  !/
  !/ Public index closure types (for lat/lon grids only)
  !/   ICLO_NONE : no closure in index space
  !/   ICLO_SMPL : synonym for ICLO_GRDI
  !/   ICLO_GRDI : closure in i-index at i=UBX+1: (UBX+1, j) => (LBX, j)
  !/   ICLO_GRDJ : closure in j-index at j=UBY+1: (i, UBY+1) => (i, LBY)
  !/   ICLO_TRDL : toroidal grid closure: (UBX+1, j) => (LBX, j) and
  !/                                      (i, UBY+1) => (i, LBY)
  !/   ICLO_TRPL : tripole grid closure: (UBX+1, LBY<=j<=UBY) => (LBX, j) and
  !/                                     (LBX<=i<=UBX, UBY+1) => (UBX+LBX-i, UBY)
  !/
  !/   Note that simple i-index closure types are set to multiples of 2.
  !/   Note that simple j-index closure types are set to multiples of 3.
  !/   These settings are used in the GSU methods to simplify checking.
  !/
  !/   Implementation notes on index closure:
  !/   Simple closure in i-index means that a given integer i' is mapped to the
  !/   range [LBX,UBX].  When i' >= LBX, the function i = LBX + MOD(i'-LBX,NX)
  !/   maps i' to i in [LBX,UBX] (where, NX = UBX - LBX + 1).  The function
  !/   i = UBX + MOD(i'-LBX+1,NX) maps any integer i' to i in [LBX,INF).  Hence,
  !/   the following composition is used to map any integer i' to [LBX,UBX].
  !/           i = LBX + MOD(NX - 1 + MOD(i' - LBX + 1, NX), NX)
  !/   Similarly, for simple closure in j-index, the following composition is used
  !/   to map any integer j' to [LBY,UBY].
  !/           j = LBY + MOD(NY - 1 + MOD(j' - LBY + 1, NY), NY)
  !/   For tripole type index closure, the simple closure in i-index is appied
  !/   prior to computing the appropriate i and j-index mapping for closure across
  !/   the seam at j = UBY.  The j-index closure for i' in [LBX,UBX] and j' > UBY
  !/   is computed as i = UBX + LBX - i' and j = 2*UBY - j' + 1.
  !/
  INTEGER, PARAMETER, PUBLIC :: iclo_none = -1
  INTEGER, PARAMETER, PUBLIC :: iclo_smpl =  2
  INTEGER, PARAMETER, PUBLIC :: iclo_grdi =  iclo_smpl
  INTEGER, PARAMETER, PUBLIC :: iclo_grdj =  3
  INTEGER, PARAMETER, PUBLIC :: iclo_trdl =  6
  INTEGER, PARAMETER, PUBLIC :: iclo_trpl =  8
  !/
  !/ Public grid-search-utility type
  !/ This is an opaque type -- that is, it's internals are private and only
  !/ accessible to subroutines in this module where the type is declared.
  !/
  TYPE, PUBLIC :: t_gsu
    PRIVATE
    TYPE(class_gsu), POINTER :: ptr => null()
  END TYPE t_gsu
  !/
  !/ Private grid-search-utility class
  !/
  TYPE :: class_gsu
    LOGICAL :: ijg  ! grid array ordering flag: T = (NX,NY), F = (NY,NX)
    LOGICAL :: llg  ! spherical coordinate flag of associated grid
    INTEGER :: iclo ! parameter indicating type of index space closure
    ! this flag must be set by the user
    LOGICAL :: lclo ! flag indicating longitudinal periodicity
    ! this flag is calculated internally
    ! LLG & ICLO != ICLO_NONE => LCLO = T
    LOGICAL :: l360 ! flag indicating longitude range:
    !   T = [0:360],  F = [-180:180]
    INTEGER :: gkind  ! kind (precision: 4 or 8) of associated grid
    INTEGER :: lbx, lby ! lower-bounds of associated grid
    INTEGER :: ubx, uby ! upper-bounds of associated grid
    INTEGER :: nx, ny   ! dimensions of associated grid
    REAL(4), POINTER :: xg4(:,:), yg4(:,:) ! coordinates of associated grid (r4)
    REAL(8), POINTER :: xg8(:,:), yg8(:,:) ! coordinates of associated grid (r8)
    TYPE(t_nns), POINTER :: nnp  ! nearest-neighbor point search indices object
    INTEGER :: nbx, nby  ! number of buckets in each spatial direction
    REAL(8) :: dxb, dyb  ! spatial extent of each search bucket
    REAL(8) :: xmin, ymin, xmax, ymax ! bounding box of search domain
    TYPE(t_bkt), POINTER :: b(:,:) ! array of search buckets
    TYPE(t_nns), POINTER :: nnb  ! nearest-neighbor bucket search indices object
  END TYPE class_gsu
  !/
  !/ Private search bucket type
  !/
  TYPE :: t_bkt
    INTEGER :: n  ! number of cells in bucket
    INTEGER, POINTER :: i(:)  ! i-index of cell c
    INTEGER, POINTER :: j(:)  ! j-index of cell c
  END TYPE t_bkt
  !/
  !/ Public nearest-neighbor grid-point search type
  !/
  TYPE, PUBLIC :: t_nns
    INTEGER :: nlvl  ! number of nnbr levels
    INTEGER :: nnbr  ! total number of nnbr's
    INTEGER, POINTER :: n1(:)  ! starting nearest-nbr loop index for level l
    INTEGER, POINTER :: n2(:)  ! ending nearest-nbr loop index for level l
    INTEGER, POINTER :: di(:)  ! i-index delta for nearest-nbr n
    INTEGER, POINTER :: dj(:)  ! j-index delta for nearest-nbr n
  END TYPE t_nns
  !/
  !/ Private module parameters
  !/
  REAL(8), PARAMETER :: pi = 3.14159265358979323846d0
  REAL(8), PARAMETER :: pi2 = 2d0*pi
  REAL(8), PARAMETER :: pi3h = 3d0*pi/2d0
  REAL(8), PARAMETER :: pio2 = pi/2d0
  REAL(8), PARAMETER :: pio4 = pi/4d0
  REAL(8), PARAMETER :: d2r = pi/180d0
  REAL(8), PARAMETER :: r2d = 1d0/d2r
  REAL(8), PARAMETER :: d360 = 360d0
  REAL(8), PARAMETER :: d270 = 270d0
  REAL(8), PARAMETER :: d180 = 180d0
  REAL(8), PARAMETER :: d90  =  90d0
  REAL(8), PARAMETER :: zero = 0.0d0
  REAL(8), PARAMETER :: half = 0.5d0
  REAL(8), PARAMETER :: one  = 1.0d0
  REAL(8), PARAMETER :: two  = 2.0d0
  REAL(8), PARAMETER :: four = 4.0d0
#if defined(COAMPS)
  REAL(8), PARAMETER :: rearth = 6371229.d0
#else
  REAL(8), PARAMETER :: rearth = 4.d7/pi2 !this gives D2M = 111111.111111
#endif
  REAL(8), PARAMETER :: d2m  = rearth*d2r
  REAL(8), PARAMETER :: m2d  = 1d0/d2m
  !     Default small non-zero tolerance used to check if
  !     target point is in domain and for point coincidence.
  REAL(8), PARAMETER :: eps_default  = 1.0d-6
  !     Distance (deg) from pole to consider a cell "near the pole"
  REAL(8), PARAMETER :: near_pole = 10.0d0
  !     Default number of grid cells (in each direction) per search bucket.
  INTEGER, PARAMETER :: ncb_default = 10
  !     Default maximum number of nearest-neighbor grid point search levels.
  INTEGER, PARAMETER :: nnp_default = 2
  !     Max number of non-empty levels for bucket search when target point
  !     is outside source domain
  INTEGER, PARAMETER :: max_fncl_level = 3
  !     Default finite-difference order
  INTEGER, PARAMETER :: nfd_default = 4
  !/
  !/ Module Interfaces
  !/
  INTERFACE w3gsuc
    MODULE PROCEDURE w3gsuc_ptr_r4
    MODULE PROCEDURE w3gsuc_ptr_r8
    MODULE PROCEDURE w3gsuc_tgt_r4
    MODULE PROCEDURE w3gsuc_tgt_r8
  END INTERFACE w3gsuc
  INTERFACE w3bbox
    MODULE PROCEDURE w3bbox_gsu
    MODULE PROCEDURE w3bbox_grd_ptr_r4
    MODULE PROCEDURE w3bbox_grd_ptr_r8
    MODULE PROCEDURE w3bbox_grd_tgt_r4
    MODULE PROCEDURE w3bbox_grd_tgt_r8
  END INTERFACE w3bbox
  INTERFACE w3gfcl
    MODULE PROCEDURE w3gfcl_r4
    MODULE PROCEDURE w3gfcl_r8
  END INTERFACE w3gfcl
  INTERFACE w3gfcd
    MODULE PROCEDURE w3gfcd_r4
    MODULE PROCEDURE w3gfcd_r8
  END INTERFACE w3gfcd
  INTERFACE w3gfpt
    MODULE PROCEDURE w3gfpt_r4
    MODULE PROCEDURE w3gfpt_r8
  END INTERFACE w3gfpt
  INTERFACE w3gfij
    MODULE PROCEDURE w3gfij_r4
    MODULE PROCEDURE w3gfij_r8
  END INTERFACE w3gfij
  INTERFACE w3grmp
    MODULE PROCEDURE w3grmp_r4
    MODULE PROCEDURE w3grmp_r8
  END INTERFACE w3grmp
  INTERFACE w3grmc
    MODULE PROCEDURE w3grmc_r4
    MODULE PROCEDURE w3grmc_r8
  END INTERFACE w3grmc
  INTERFACE w3cgdm
    MODULE PROCEDURE w3cgdm_r4
    MODULE PROCEDURE w3cgdm_r8
  END INTERFACE w3cgdm
  INTERFACE w3grd0
    MODULE PROCEDURE w3grd0_r4
    MODULE PROCEDURE w3grd0_r8
  END INTERFACE w3grd0
  INTERFACE w3div1
    MODULE PROCEDURE w3div1_r4
    MODULE PROCEDURE w3div1_r8
  END INTERFACE w3div1
  INTERFACE w3div2
    MODULE PROCEDURE w3div2_r4
    MODULE PROCEDURE w3div2_r8
  END INTERFACE w3div2
  INTERFACE w3dist
    MODULE PROCEDURE w3dist_r4
    MODULE PROCEDURE w3dist_r8
  END INTERFACE w3dist
  INTERFACE w3splx
    MODULE PROCEDURE w3splx_0d_r4
    MODULE PROCEDURE w3splx_0d_r8
    MODULE PROCEDURE w3splx_1d_r4
    MODULE PROCEDURE w3splx_1d_r8
    MODULE PROCEDURE w3splx_2d_r4
    MODULE PROCEDURE w3splx_2d_r8
  END INTERFACE w3splx
  INTERFACE w3spxl
    MODULE PROCEDURE w3spxl_0d_r4
    MODULE PROCEDURE w3spxl_0d_r8
    MODULE PROCEDURE w3spxl_1d_r4
    MODULE PROCEDURE w3spxl_1d_r8
    MODULE PROCEDURE w3spxl_2d_r4
    MODULE PROCEDURE w3spxl_2d_r8
  END INTERFACE w3spxl
  INTERFACE w3trll
    MODULE PROCEDURE w3trll_0d_r4
    MODULE PROCEDURE w3trll_0d_r8
    MODULE PROCEDURE w3trll_1d_r4
    MODULE PROCEDURE w3trll_1d_r8
    MODULE PROCEDURE w3trll_2d_r4
    MODULE PROCEDURE w3trll_2d_r8
  END INTERFACE w3trll
  INTERFACE w3llaz
    MODULE PROCEDURE w3llaz_r4
    MODULE PROCEDURE w3llaz_r8
  END INTERFACE w3llaz
  INTERFACE w3fdwt
    MODULE PROCEDURE w3fdwt_r4
    MODULE PROCEDURE w3fdwt_r8
  END INTERFACE w3fdwt
  INTERFACE w3ckcl
    MODULE PROCEDURE w3ckcl_r4
    MODULE PROCEDURE w3ckcl_r8
  END INTERFACE w3ckcl
  INTERFACE w3sort
    MODULE PROCEDURE w3sort_r4
    MODULE PROCEDURE w3sort_r8
  END INTERFACE w3sort
  INTERFACE w3isrt
    MODULE PROCEDURE w3isrt_r4
    MODULE PROCEDURE w3isrt_r8
  END INTERFACE w3isrt
  INTERFACE w3inan
    MODULE PROCEDURE w3inan_r4
    MODULE PROCEDURE w3inan_r8
  END INTERFACE w3inan
 
  !/
CONTAINS
  !/
  !/ =================================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3GSUC( IJG, LLG, ICLO, XG, YG, &
  !/                     NCB, NNP, DEBUG ) RESULT(GSU)
  !/      OR
  !/    FUNCTION W3GSUC( IJG, LLG, ICLO, LB, UB, XG, YG, &
  !/                     NCB, NNP, DEBUG ) RESULT(GSU)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Create grid-search-utility (GSU) object for a logically rectangular
  !     grid defined by the input coordinates.
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Return parameter
  !     ----------------------------------------------------------------
  !       GSU     Type   O   Created grid-search-utility object.
  !     ----------------------------------------------------------------
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       IJG     Log.   I   Logical flag indicating ordering of input
  !                          coord. arrays: T = (NX,NY) and F = (NY,NX).
  !       LLG     Log.   I   Logical flag indicating the coordinate system:
  !                          T = spherical lat/lon (degrees) and F = Cartesian.
  !       ICLO    Int.   I   Parameter indicating type of index space closure
  !
  !     Inputs (for W3GSUC_PTR):
  !       XG      R.A.   I   Pointer to array of x-coordinates of input grid.
  !       YG      R.A.   I   Pointer to array of y-coordinates of input grid.
  !
  !     Inputs (for W3GSUC_TGT):
  !       LB      I.A.   I   Lower bounds of XG and YG arrays
  !       UB      I.A.   I   Upper bounds of XG and YG arrays
  !       XG      R.A.   I   Array of x-coordinates of input grid.
  !       YG      R.A.   I   Array of y-coordinates of input grid.
  !
  !       NCB     Int.   I   OPTIONAL (approximate) number of cells (in each
  !                          direction) per search bucket. (default is NCB_DEFAULT)
  !                          NCB >= 1 is required.  NCB = 1 gives most efficient
  !                          searching, but uses more memory. Increasing NCB leads
  !                          to fewer buckets (less memory) but slower searching.
  !       NNP     Int.   I   OPTIONAL maximum number of nearest-neighbor grid
  !                          point search levels. (default is NNP_DEFAULT)
  !       DEBUG   Log.   I   OPTIONAL logical flag to turn on debug mode.
  !                          Default is FALSE.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !     - Check on correct coordinate system with global grid.
  !     - Check on association of input grid coordinate array pointers.
  !
  !  7. Remarks :
  !
  !     - LCLO is calculated internally.
  !     - LLG & ICLO != ICLO_NONE => LCLO = T.
  !     - Periodic Cartesian grids are not allowed.
  !
  !  8. Structure :
  !
  !     -----------------------------------------------------------------
  !      1.  Test input
  !      2.  Allocate object and set grid related data and pointers
  !      3.  Create nearest-neighbor point search object
  !      4.  Construct bucket search "object"
  !      5.  Set return parameter
  !     -----------------------------------------------------------------
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gsuc_ptr_r4( IJG, LLG, ICLO, XG, YG, &
       NCB, NNP, DEBUG ) RESULT(GSU)
    !     Single precision pointer interface
    TYPE(t_gsu)         :: gsu
    LOGICAL, INTENT(IN) :: ijg
    LOGICAL, INTENT(IN) :: llg
    INTEGER, INTENT(IN) :: iclo
    REAL(4), POINTER    :: xg(:,:)
    REAL(4), POINTER    :: yg(:,:)
    INTEGER, INTENT(IN), OPTIONAL :: ncb
    INTEGER, INTENT(IN), OPTIONAL :: nnp
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    INTEGER :: lb(2), ub(2)
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GSUC_PTR_R4')
#endif
    !
    lb(1) = lbound(xg,1); lb(2) = lbound(xg,2)
    ub(1) = ubound(xg,1); ub(2) = ubound(xg,2)
    gsu = gsu_create( ijg, llg, iclo, lb, ub, xg4=xg, yg4=yg, &
         ncb=ncb, nnp=nnp, debug=debug)
 
  END FUNCTION w3gsuc_ptr_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gsuc_ptr_r8( IJG, LLG, ICLO, XG, YG, &
       NCB, NNP, DEBUG ) RESULT(GSU)
    !     Double precision pointer interface
    TYPE(t_gsu)         :: gsu
    LOGICAL, INTENT(IN) :: ijg
    LOGICAL, INTENT(IN) :: llg
    INTEGER, INTENT(IN) :: iclo
    REAL(8), POINTER    :: xg(:,:)
    REAL(8), POINTER    :: yg(:,:)
    INTEGER, INTENT(IN), OPTIONAL :: ncb
    INTEGER, INTENT(IN), OPTIONAL :: nnp
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    INTEGER :: lb(2), ub(2)
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GSUC_PTR_R4')
#endif
    !
    lb(1) = lbound(xg,1); lb(2) = lbound(xg,2)
    ub(1) = ubound(xg,1); ub(2) = ubound(xg,2)
    gsu = gsu_create( ijg, llg, iclo, lb, ub, xg8=xg, yg8=yg, &
         ncb=ncb, nnp=nnp, debug=debug)
 
  END FUNCTION w3gsuc_ptr_r8
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gsuc_tgt_r4( IJG, LLG, ICLO, LB, UB, XG, YG, &
       NCB, NNP, DEBUG ) RESULT(GSU)
    !     Single precision target interface
    TYPE(t_gsu)         :: gsu
    LOGICAL, INTENT(IN) :: ijg
    LOGICAL, INTENT(IN) :: llg
    INTEGER, INTENT(IN) :: iclo
    INTEGER, INTENT(IN) :: lb(2)
    INTEGER, INTENT(IN) :: ub(2)
    REAL(4), TARGET     :: xg(lb(1):ub(1),lb(2):ub(2))
    REAL(4), TARGET     :: yg(lb(1):ub(1),lb(2):ub(2))
    INTEGER, INTENT(IN), OPTIONAL :: ncb
    INTEGER, INTENT(IN), OPTIONAL :: nnp
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GSUC_TGT_R4')
#endif
    !
    gsu = gsu_create( ijg, llg, iclo, lb, ub, xg4=xg, yg4=yg, &
         ncb=ncb, nnp=nnp, debug=debug)
 
  END FUNCTION w3gsuc_tgt_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gsuc_tgt_r8( IJG, LLG, ICLO, LB, UB, XG, YG, &
       NCB, NNP, DEBUG ) RESULT(GSU)
    !     Double precision target interface
    TYPE(t_gsu)         :: gsu
    LOGICAL, INTENT(IN) :: ijg
    LOGICAL, INTENT(IN) :: llg
    INTEGER, INTENT(IN) :: iclo
    INTEGER, INTENT(IN) :: lb(2)
    INTEGER, INTENT(IN) :: ub(2)
    REAL(8), TARGET     :: xg(lb(1):ub(1),lb(2):ub(2))
    REAL(8), TARGET     :: yg(lb(1):ub(1),lb(2):ub(2))
    INTEGER, INTENT(IN), OPTIONAL :: ncb
    INTEGER, INTENT(IN), OPTIONAL :: nnp
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GSUC_TGT_R8')
#endif
    !
    gsu = gsu_create( ijg, llg, iclo, lb, ub, xg8=xg, yg8=yg, &
         ncb=ncb, nnp=nnp, debug=debug)
 
  END FUNCTION w3gsuc_tgt_r8
  !/
  !/ End of W3GSUC ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3GSUD( GSU )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Destroy grid search utility (GSU) object.
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       GSU     Type   I   Grid-search-utility object.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !     - Check on previous creation of grid-search-utility object.
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3gsud( GSU )
    TYPE(t_gsu), INTENT(INOUT) :: gsu
 
    !     Local parameters
    INTEGER :: ib, jb
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GSUD')
#endif
    !
    IF ( ASSOCIATED(gsu%PTR) ) THEN
      !
      CALL w3nnsd(gsu%PTR%NNP)
      !
      IF ( ASSOCIATED(gsu%PTR%B) ) THEN
        DO ib=1,gsu%PTR%NBX
          DO jb=1,gsu%PTR%NBY
            IF ( gsu%PTR%B(jb,ib)%N .GT. 0 ) THEN
              DEALLOCATE(gsu%PTR%B(jb,ib)%I)
              NULLIFY(gsu%PTR%B(jb,ib)%I)
              DEALLOCATE(gsu%PTR%B(jb,ib)%J)
              NULLIFY(gsu%PTR%B(jb,ib)%J)
            END IF
          END DO
        END DO
        DEALLOCATE(gsu%PTR%B)
        NULLIFY(gsu%PTR%B)
      END IF
      !
      CALL w3nnsd(gsu%PTR%NNB)
      !
      DEALLOCATE(gsu%PTR)
      NULLIFY(gsu%PTR)
      !
    END IF
 
  END SUBROUTINE w3gsud
  !/
  !/ End of W3GSUD ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3GSUP( GSU, IUNIT, LFULL )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Print grid-search-utility (GSU) object to IUNIT.
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       GSU     Type   I   Grid-search-utility object.
  !       IUNIT   Int.   I   OPTIONAL unit for output. Default is stdout.
  !       LFULL   Log.   I   OPTIONAL logical flag to turn on full-output
  !                          mode.  Default is FALSE.  When full-output
  !                          is enabled the search bucket cell lists and
  !                          nearest-neighbor point search indices are output.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !     - Check on previous creation of grid-search-utility object.
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3gsup( GSU, IUNIT, LFULL )
    TYPE(t_gsu), INTENT(IN) :: gsu
    INTEGER, OPTIONAL, INTENT(IN) :: iunit
    LOGICAL, OPTIONAL, INTENT(IN) :: lfull
 
    !     Local parameters
    INTEGER, PARAMETER :: nbyte_ptr=4
    INTEGER, PARAMETER :: nbyte_int=4
    TYPE(class_gsu), POINTER :: ptr
    INTEGER :: ndst, k, ib, jb, nbyte
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GSUP')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Test input
    !
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/1A,1A/)') 'W3GSUP ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
 
    IF ( PRESENT(iunit) ) THEN
      ndst = iunit
    ELSE
      ndst = 6
    END IF
 
    ptr => gsu%PTR
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Compute approximate memory usage
    !
    nbyte = (nbyte_int+nbyte_ptr*2)*SIZE(ptr%B)
    DO ib=1,ptr%NBX
      DO jb=1,ptr%NBY
        nbyte = nbyte + nbyte_int*2*ptr%B(jb,ib)%N
      END DO
    END DO
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Output
    !
    WRITE(ndst,'(//80A)') ('-',k=1,80)
    WRITE(ndst,'(A)') 'Report on grid search utility object'
    WRITE(ndst,'( 80A)') ('-',k=1,80)
    WRITE(ndst,'(A,1L2)') 'Grid  ijg:',ptr%IJG
    WRITE(ndst,'(A,1L2)') 'Grid  llg:',ptr%LLG
    WRITE(ndst,'(A,1I2)') 'Grid iclo:',ptr%ICLO
    WRITE(ndst,'(A,1L2)') 'Grid lclo:',ptr%LCLO
    WRITE(ndst,'(A,1I2)') 'Grid precision:',ptr%GKIND
    WRITE(ndst,'(A,2I6)') 'Grid lbx,lby:',ptr%LBX,ptr%LBY
    WRITE(ndst,'(A,2I6)') 'Grid ubx,uby:',ptr%UBX,ptr%UBY
    WRITE(ndst,'(A,2I6)') 'Grid  nx, ny:',ptr%NX,ptr%NY
    IF ( PRESENT(lfull) ) THEN
      IF ( lfull ) THEN
        WRITE(ndst,'( 80A)') ('-',k=1,80)
        WRITE(ndst,'(A)') 'Nearest-neighbor point search indices'
        WRITE(ndst,'( 80A)') ('-',k=1,80)
        CALL w3nnsp(ptr%NNP,ndst)
      END IF
    END IF
    WRITE(ndst,'( 80A)') ('-',k=1,80)
    WRITE(ndst,'(A)') 'Bucket-search object'
    WRITE(ndst,'( 80A)') ('-',k=1,80)
    WRITE(ndst,'(A,4E24.16)') 'Spatial grid search domain: ', &
         ptr%XMIN,ptr%YMIN,ptr%XMAX,ptr%YMAX
    WRITE(ndst,'(A,2I6)') 'nbx,nby:',ptr%NBX,ptr%NBY
    WRITE(ndst,'(A,2E24.16)') 'dxb,dyb:',ptr%DXB,ptr%DYB
    WRITE(ndst,'(A,1F10.1)') 'Approximate memory usage (MB):', &
         REAL(nbyte)/2**20
    IF ( PRESENT(lfull) ) THEN
      IF ( lfull ) THEN
        WRITE(ndst,'( 80A)') ('-',k=1,80)
        WRITE(ndst,'(A)') 'Search bucket bounds:'
        WRITE(ndst,'( 80A)') ('-',k=1,80)
        WRITE(ndst,'(2A4,4A24)') 'IB','JB','X1','Y1','X2','Y2'
        DO ib=1,ptr%NBX
          DO jb=1,ptr%NBY
            WRITE(ndst,'(2I4,4E24.16)') ib,jb, &
                 ptr%XMIN+(ib-1)*ptr%DXB,ptr%YMIN+(jb-1)*ptr%DYB, &
                 ptr%XMIN+(ib  )*ptr%DXB,ptr%YMIN+(jb  )*ptr%DYB
          END DO
        END DO
        WRITE(ndst,'( 80A)') ('-',k=1,80)
        WRITE(ndst,'(A)') 'Number of cells in each search bucket:'
        WRITE(ndst,'( 80A)') ('-',k=1,80)
        DO jb=ptr%NBY,1,-1
          WRITE(ndst,'(500I4)') (ptr%B(jb,ib)%N,ib=1,ptr%NBX)
        END DO
        WRITE(ndst,'( 80A)') ('-',k=1,80)
        WRITE(ndst,'(A)') 'Search bucket cell lists:'
        WRITE(ndst,'( 80A)') ('-',k=1,80)
        WRITE(ndst,'(3A4,A)') 'IB','JB','NC',': ( IC, JC), ...'
        DO jb=1,ptr%NBY
          DO ib=1,ptr%NBX
            WRITE(ndst,'(3I4,A,500(A,I3,A,I3,A))') ib,jb, &
                 ptr%B(jb,ib)%N, ': ', &
                 ( '(',ptr%B(jb,ib)%I(k),',',ptr%B(jb,ib)%J(k),') ', &
                 k=1,ptr%B(jb,ib)%N )
          END DO
        END DO
        WRITE(ndst,'( 80A)') ('-',k=1,80)
        WRITE(ndst,'(A)') 'Nearest-neighbor bucket search indices'
        WRITE(ndst,'( 80A)') ('-',k=1,80)
        CALL w3nnsp(ptr%NNB,ndst)
      END IF !LFULL
    END IF !PRESENT(LFULL)
    WRITE(ndst,'( 80A)') ('-',k=1,80)
    WRITE(ndst,'( 80A)') ('-',k=1,80)
 
  END SUBROUTINE w3gsup
  !/
  !/ End of W3GSUP ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3BBOX( GSU, XMIN, YMIN, XMAX, YMAX )
  !/      OR
  !/    SUBROUTINE W3BBOX( IJG, LLG, ICLO, XG, YG, XMIN, YMIN, XMAX, YMAX )
  !/      OR
  !/    SUBROUTINE W3BBOX( IJG, LLG, ICLO, LB, UB, XG, YG, XMIN, YMIN, XMAX, YMAX )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Get bounding box associated with grid.
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !     Inputs (for W3BBOX_GSU):
  !       GSU     Type   I   Grid-search-utility object
  !
  !     Inputs (for W3BBOX_GRD_PTR):
  !       IJG     Log.   I   Logical flag indicating ordering of input
  !                          coord. arrays: T = (NX,NY) and F = (NY,NX).
  !       LLG     Log.   I   Logical flag indicating the coordinate system:
  !                          T = spherical lat/lon (degrees) and F = Cartesian.
  !       ICLO    Int.   I   Parameter indicating type of index space closure
  !       XG      R.A.   I   Pointer to array of x-coordinates of input grid.
  !       YG      R.A.   I   Pointer to array of y-coordinates of input grid.
  !
  !     Inputs (for W3BBOX_GRD_TGT):
  !       IJG     Log.   I   Logical flag indicating ordering of input
  !                          coord. arrays: T = (NX,NY) and F = (NY,NX).
  !       LLG     Log.   I   Logical flag indicating the coordinate system:
  !                          T = spherical lat/lon (degrees) and F = Cartesian.
  !       ICLO    Int.   I   Parameter indicating type of index space closure
  !       LB      I.A.   I   Lower bounds of XG and YG arrays
  !       UB      I.A.   I   Upper bounds of XG and YG arrays
  !       XG      R.A.   I   Array of x-coordinates of input grid.
  !       YG      R.A.   I   Array of y-coordinates of input grid.
  !
  !     Outputs:
  !       XMIN    Int.   O   Minimum X-coord of bounding box
  !       YMIN    Int.   O   Minimum Y-coord of bounding box
  !       XMAX    Int.   O   Maximum X-coord of bounding box
  !       YMAX    Int.   O   Maximum Y-coord of bounding box
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !     - Check on previous creation of grid-search-utility object.
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3bbox_gsu( GSU, XMIN, YMIN, XMAX, YMAX )
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(8), INTENT(OUT)    :: xmin, ymin, xmax, ymax
 
    !     Local parameters
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3BBOX_GSU')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Test input
    !
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/1A,1A/)') 'W3BBOX_GSU ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Set bounding box
    !
    xmin = gsu%PTR%XMIN
    ymin = gsu%PTR%YMIN
    xmax = gsu%PTR%XMAX
    ymax = gsu%PTR%YMAX
 
  END SUBROUTINE w3bbox_gsu
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3bbox_grd_ptr_r4( IJG, LLG, ICLO, XG, YG, &
       XMIN, YMIN, XMAX, YMAX )
    LOGICAL, INTENT(IN)     :: ijg
    LOGICAL, INTENT(IN)     :: llg
    INTEGER, INTENT(IN)     :: iclo
    REAL(4), POINTER        :: xg(:,:)
    REAL(4), POINTER        :: yg(:,:)
    REAL(8), INTENT(OUT)    :: xmin, ymin, xmax, ymax
 
    !     Local parameters
    TYPE(t_gsu) :: gsu
    INTEGER :: lb(2), ub(2)
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3BBOX_GRD_PTR_R4')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Set bounding box
    !
    lb(1) = lbound(xg,1); lb(2) = lbound(xg,2)
    ub(1) = ubound(xg,1); ub(2) = ubound(xg,2)
    gsu = gsu_create( ijg, llg, iclo, lb, ub, xg4=xg, yg4=yg, bbox_only=.true. )
    xmin = gsu%PTR%XMIN
    ymin = gsu%PTR%YMIN
    xmax = gsu%PTR%XMAX
    ymax = gsu%PTR%YMAX
    CALL w3gsud( gsu )
 
  END SUBROUTINE w3bbox_grd_ptr_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3bbox_grd_ptr_r8( IJG, LLG, ICLO, XG, YG, &
       XMIN, YMIN, XMAX, YMAX )
    LOGICAL, INTENT(IN)     :: ijg
    LOGICAL, INTENT(IN)     :: llg
    INTEGER, INTENT(IN)     :: iclo
    REAL(8), POINTER        :: xg(:,:)
    REAL(8), POINTER        :: yg(:,:)
    REAL(8), INTENT(OUT)    :: xmin, ymin, xmax, ymax
 
    !     Local parameters
    TYPE(t_gsu) :: gsu
    INTEGER :: lb(2), ub(2)
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3BBOX_GRD_PTR_R8')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Set bounding box
    !
    lb(1) = lbound(xg,1); lb(2) = lbound(xg,2)
    ub(1) = ubound(xg,1); ub(2) = ubound(xg,2)
    gsu = gsu_create( ijg, llg, iclo, lb, ub, xg8=xg, yg8=yg, bbox_only=.true. )
    xmin = gsu%PTR%XMIN
    ymin = gsu%PTR%YMIN
    xmax = gsu%PTR%XMAX
    ymax = gsu%PTR%YMAX
    CALL w3gsud( gsu )
 
  END SUBROUTINE w3bbox_grd_ptr_r8
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3bbox_grd_tgt_r4( IJG, LLG, ICLO, LB, UB, XG, YG, &
       XMIN, YMIN, XMAX, YMAX )
    LOGICAL, INTENT(IN)     :: ijg
    LOGICAL, INTENT(IN)     :: llg
    INTEGER, INTENT(IN)     :: iclo
    INTEGER, INTENT(IN)     :: lb(2), ub(2)
    REAL(4), TARGET         :: xg(lb(1):ub(1),lb(2):ub(2))
    REAL(4), TARGET         :: yg(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(OUT)    :: xmin, ymin, xmax, ymax
 
    !     Local parameters
    TYPE(t_gsu) :: gsu
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3BBOX_GRD_TGT_R4')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Set bounding box
    !
    gsu = gsu_create( ijg, llg, iclo, lb, ub, xg4=xg, yg4=yg, bbox_only=.true. )
    xmin = gsu%PTR%XMIN
    ymin = gsu%PTR%YMIN
    xmax = gsu%PTR%XMAX
    ymax = gsu%PTR%YMAX
    CALL w3gsud( gsu )
 
  END SUBROUTINE w3bbox_grd_tgt_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3bbox_grd_tgt_r8( IJG, LLG, ICLO, LB, UB, XG, YG, &
       XMIN, YMIN, XMAX, YMAX )
    LOGICAL, INTENT(IN)     :: ijg
    LOGICAL, INTENT(IN)     :: llg
    INTEGER, INTENT(IN)     :: iclo
    INTEGER, INTENT(IN)     :: lb(2), ub(2)
    REAL(8), TARGET         :: xg(lb(1):ub(1),lb(2):ub(2))
    REAL(8), TARGET         :: yg(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(OUT)    :: xmin, ymin, xmax, ymax
 
    !     Local parameters
    TYPE(t_gsu) :: gsu
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3BBOX_GRD_TGT_R8')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Set bounding box
    !
    gsu = gsu_create( ijg, llg, iclo, lb, ub, xg8=xg, yg8=yg, bbox_only=.true. )
    xmin = gsu%PTR%XMIN
    ymin = gsu%PTR%YMIN
    xmax = gsu%PTR%XMAX
    ymax = gsu%PTR%YMAX
    CALL w3gsud( gsu )
 
  END SUBROUTINE w3bbox_grd_tgt_r8
  !/
  !/ End of W3BBOX ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3GFCL( GSU, XT, YT, IS, JS, XS, YS, &
  !/                     POLE, EPS, FNCL, DEBUG ) RESULT(INGRID)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Find cell in grid, associated with the input grid-search-utility
  !     object (GSU), that encloses the target point (xt,yt).
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Return parameter
  !     ----------------------------------------------------------------
  !       INGRID  Log.   O   Logical flag indicating if target point lies
  !                          within the source grid domain.
  !     ----------------------------------------------------------------
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       GSU     Type   I   Grid-search-utility object.
  !       XT      Real   I   X-coordinate of target point.
  !       YT      Real   I   Y-coordinate of target point.
  !       IS,JS   I.A.   O   (I,J) indices of vertices of enclosing grid cell.
  !       XS,YS   R.A.   O   (X,Y) coord. of vertices of enclosing grid cell.
  !       POLE    Log.   O   OPTIONAL logical flag to indicate whether or not
  !                          the enclosing grid cell includes a pole.
  !       EPS     Real   I   OPTIONAL small non-zero tolerance used to check if
  !                          target point is in domain and for point coincidence.
  !       FNCL    Log.   I   OPTIONAL logical flag to enable finding cell that
  !                          is shortest distance from target point when the
  !                          target point is not located in the source grid.
  !                          Default is FALSE.
  !       DEBUG   Log.   I   OPTIONAL logical flag to turn on debug mode.
  !                          Default is FALSE.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !     - Check on previous creation of grid-search-utility object.
  !
  !  7. Remarks :
  !
  !     - The target point coordinates may be modified by this routine.
  !     - The target point longitude will be shifted to the source grid
  !       longitudinal range.
  !     - If enclosing cell includes a branch cut, then the coordinates of
  !       of the cell vertices AND the target point will be adjusted so
  !       that the branch cut is shifted 180 degrees.
  !
  !  8. Structure :
  !
  !     -----------------------------------------------------------------
  !      1.  Test input
  !      2.  Initialize search
  !      3.  Search for enclosing cell in central and nearest nbr buckets
  !      4.  If not in grid and find nearest cell is enabled, then
  !          identify cell closest to target point
  !     -----------------------------------------------------------------
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gfcl_r4( GSU, XT, YT, IS, JS, XS, YS, &
       POLE, EPS, FNCL, DEBUG ) RESULT(INGRID)
    !     Single precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(4), INTENT(INOUT)  :: xt
    REAL(4), INTENT(INOUT)  :: yt
    INTEGER, INTENT(INOUT)  :: is(4), js(4)
    REAL(4), INTENT(INOUT)  :: xs(4), ys(4)
    LOGICAL, INTENT(OUT),OPTIONAL :: pole
    REAL(4), INTENT(IN), OPTIONAL :: eps
    LOGICAL, INTENT(IN), OPTIONAL :: fncl
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    REAL(8) :: xt8, yt8, xs8(4), ys8(4), eps8
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GFCL_R4')
#endif
    !
    !-----set inputs
    xt8 = xt; yt8 = yt;
    IF ( PRESENT(eps) ) THEN
      eps8 = eps
    ELSE
      eps8 = eps_default
    END IF
    !
    !-----call double precision method
    ingrid = w3gfcl( gsu, xt8, yt8, is, js, xs8, ys8, pole=pole, &
         eps=eps8, fncl=fncl, debug=debug )
    !
    !-----set outputs
    xt = xt8; yt = yt8;
    xs = xs8; ys = ys8;
 
  END FUNCTION w3gfcl_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gfcl_r8( GSU, XT, YT, IS, JS, XS, YS, &
       POLE, EPS, FNCL, DEBUG ) RESULT(INGRID)
    !     Double precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(8), INTENT(INOUT)  :: xt
    REAL(8), INTENT(INOUT)  :: yt
    INTEGER, INTENT(INOUT)  :: is(4), js(4)
    REAL(8), INTENT(INOUT)  :: xs(4), ys(4)
    LOGICAL, INTENT(OUT),OPTIONAL :: pole
    REAL(8), INTENT(IN), OPTIONAL :: eps
    LOGICAL, INTENT(IN), OPTIONAL :: fncl
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    REAL(8) :: leps
    LOGICAL :: ldbg, lplc, lfncl, incell
    INTEGER :: i, j, k, l, n, ib, jb
    LOGICAL :: ijg, llg, lclo, l360
    INTEGER :: iclo, gkind
    INTEGER :: lbx, lby, ubx, uby, nx, ny
    REAL(4), POINTER :: xg4(:,:), yg4(:,:)
    REAL(8), POINTER :: xg8(:,:), yg8(:,:)
    INTEGER :: nbx, nby
    REAL(8) :: dxb, dyb, xmin, xmax, ymin, ymax
    TYPE(t_bkt), POINTER :: b(:,:)
    TYPE(t_nns), POINTER :: nnb
    LOGICAL :: found
    INTEGER :: nlevel, lvl, lvl1, n1, ib0, jb0, ib1, jb1, k1
    INTEGER :: is1(4), js1(4)
    REAL(8) :: xs1(4), ys1(4), xsm, ysm, dd, dd1
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GFCL_R8')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Test input
    !
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/2A/)') 'W3GFCL_R8 ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
    IF ( PRESENT(eps) ) THEN
      IF ( eps .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GFCL_R8 ERROR -- ', &
             'EPS parameter must be >= 0'
        CALL extcde (1)
      END IF
      leps = eps
    ELSE
      leps = eps_default
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Initialize search
    !
    IF ( PRESENT(fncl) ) THEN
      lfncl = fncl
    ELSE
      lfncl = .false.
    END IF
    IF ( PRESENT(debug) ) THEN
      ldbg = debug
    ELSE
      ldbg = .false.
    END IF
    !
    !  Local pointers to grid search utility object data
    ijg = gsu%PTR%IJG
    llg = gsu%PTR%LLG
    iclo = gsu%PTR%ICLO
    lclo = gsu%PTR%LCLO
    l360 = gsu%PTR%L360
    gkind = gsu%PTR%GKIND
    lbx = gsu%PTR%LBX;  lby = gsu%PTR%LBY;
    ubx = gsu%PTR%UBX;  uby = gsu%PTR%UBY;
    nx = gsu%PTR%NX;  ny = gsu%PTR%NY;
    IF ( gkind.EQ.4 ) THEN
      xg4 => gsu%PTR%XG4;  yg4 => gsu%PTR%YG4;
    ELSE
      xg8 => gsu%PTR%XG8;  yg8 => gsu%PTR%YG8;
    END IF
    nbx = gsu%PTR%NBX;  nby = gsu%PTR%NBY;
    dxb = gsu%PTR%DXB;  dyb = gsu%PTR%DYB;
    xmin = gsu%PTR%XMIN;  ymin = gsu%PTR%YMIN;
    xmax = gsu%PTR%XMAX;  ymax = gsu%PTR%YMAX;
    b => gsu%PTR%B
    nnb => gsu%PTR%NNB
    !
    ingrid = .false.
    !
    !  Shift target to appropriate longitude range
    IF ( llg ) THEN
      xt = mod(xt,real(d360,8))
      IF ( lclo .OR. l360 ) THEN
        IF ( xt.LT.zero ) xt = xt + d360
      ELSE
        IF ( xt.GT.d180 ) xt = xt - d360
      END IF
    END IF
    IF ( ldbg ) WRITE(*,'(/A,2E24.16)') 'W3GFCL_R8 - TARGET POINT:',xt,yt
    !
    !  Target point must lie within search domain
    IF ( .NOT.lfncl ) THEN
      IF ( xt.LT.xmin-leps .OR. xt.GT.xmax+leps .OR. &
           yt.LT.ymin-leps .OR. yt.GT.ymax+leps ) THEN
        IF ( ldbg ) WRITE(*,'(A)') &
             'W3GFCL_R8 - TARGET POINT OUTSIDE SEARCH DOMAIN'
        RETURN
      END IF
    END IF
    !
    !  Search bucket that contains the target point.
    ib = max(int((xt-xmin)/dxb)+1,1);  IF ( .NOT.lclo ) ib = min(ib,nbx);
    jb = max(int((yt-ymin)/dyb)+1,1);                   jb = min(jb,nby);
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Search for enclosing cell in bucket
    !
    IF ( ldbg ) &
         WRITE(*,'(A,3I6,4E24.16)') &
         'W3GFCL_R8 - BUCKET SEARCH:',ib,jb,b(jb,ib)%N, &
         xmin+(ib-1)*dxb,ymin+(jb-1)*dyb,xmin+ib*dxb,ymin+jb*dyb
    cell_loop: DO k=1,b(jb,ib)%N
      !---------setup cell corner indices
      is(1) = b(jb,ib)%I(k)  ;  js(1) = b(jb,ib)%J(k)  ;
      is(2) = b(jb,ib)%I(k)+1;  js(2) = b(jb,ib)%J(k)  ;
      is(3) = b(jb,ib)%I(k)+1;  js(3) = b(jb,ib)%J(k)+1;
      is(4) = b(jb,ib)%I(k)  ;  js(4) = b(jb,ib)%J(k)+1;
      !---------setup cell corner coordinates and adjust for periodicity
      DO l=1,4
        !-------------apply index closure
        IF ( mod(iclo,2).EQ.0 ) &
             is(l) = lbx + mod(nx - 1 + mod(is(l) - lbx + 1, nx), nx)
        IF ( mod(iclo,3).EQ.0 ) &
             js(l) = lby + mod(ny - 1 + mod(js(l) - lby + 1, ny), ny)
        IF ( iclo.EQ.iclo_trpl .AND. js(l).GT.uby ) THEN
          is(l) = ubx + lbx - is(l)
          js(l) = 2*uby - js(l) + 1
        END IF
        !-------------copy cell vertex coordinates into local variables
        IF ( ijg ) THEN
          IF ( gkind.EQ.4 ) THEN
            xs(l) = xg4(is(l),js(l));  ys(l) = yg4(is(l),js(l));
          ELSE
            xs(l) = xg8(is(l),js(l));  ys(l) = yg8(is(l),js(l));
          END IF
        ELSE
          IF ( gkind.EQ.4 ) THEN
            xs(l) = xg4(js(l),is(l));  ys(l) = yg4(js(l),is(l));
          ELSE
            xs(l) = xg8(js(l),is(l));  ys(l) = yg8(js(l),is(l));
          END IF
        END IF
        !-------------shift longitudes to same range
        IF ( llg ) THEN
          xs(l) = mod(xs(l),real(d360,8))
          IF ( lclo .OR. l360 ) THEN
            IF ( xs(l).LT.zero ) xs(l) = xs(l) + d360
          ELSE
            IF ( xs(l).GT.d180 ) xs(l) = xs(l) - d360
          END IF
        END IF
      END DO !L
      IF ( ldbg ) &
           WRITE(*,'(A,3I6,4(/A,1I1,A,2I6,2E24.16))') &
           'W3GFCL_R8 - CHECK CELL:',ib,jb,k, &
           ('          CORNER(',l,'):',is(l),js(l),xs(l),ys(l),l=1,4)
      !---------check if point is enclosed in cell defined by xs(1:4) & ys(1:4)
      incell = w3ckcl(llg,xt,yt,4,xs,ys,lplc,leps,ldbg)
      IF ( ldbg ) WRITE(*,'(A,1L2)')'W3GFCL_R8 - INCELL:',incell
      IF ( incell ) THEN
        !-------------exit search
        IF ( ldbg ) &
             WRITE(*,'(A,3I6,4(2I6))') &
             'W3GFCL_R8 - ENCLOSING CELL:',ib,jb,k,(is(l),js(l),l=1,4)
        IF ( PRESENT(pole) ) pole = lplc
        ingrid = .true.
        EXIT cell_loop
      END IF !point in cell
    END DO cell_loop
    IF ( ingrid ) RETURN
    IF ( .NOT.lfncl ) RETURN
    !
    ! -------------------------------------------------------------------- /
    ! 4.  If not in grid, then identify cell closest to target point
    !
    !-----find closest cell by searching nearest-neighbor buckets
    nlevel = 0
    dd1 = huge(xt)
    ib0 = ib;  jb0 = jb;
    ib1 = ib;  jb1 = jb;
    nnb = w3nnsc(nint(half*max(nbx,nby)))
    IF ( ldbg ) WRITE(*,'(A,3I6)') &
         'W3GFCL_R8 - CLOSEST CELL SEARCH:',ib0,jb0,nnb%NLVL
    level_loop: DO lvl=0,nnb%NLVL
      found = .false.
      nnbr_loop: DO n=nnb%N1(lvl),nnb%N2(lvl)
        ib = ib0 + nnb%DI(n);  jb = jb0 + nnb%DJ(n);
        IF ( ib.LT.1 .OR. ib.GT.nbx ) cycle nnbr_loop
        IF ( jb.LT.1 .OR. jb.GT.nby ) cycle nnbr_loop
        IF ( ldbg ) WRITE(*,'(A,5I6)') &
             'W3GFCL_R8 - CHECK BUCKET:',lvl,n,ib,jb,b(jb,ib)%N
        cell_loop2: DO k=1,b(jb,ib)%N
          !-----------------setup cell corner indices
          is(1) = b(jb,ib)%I(k)  ;  js(1) = b(jb,ib)%J(k)  ;
          is(2) = b(jb,ib)%I(k)+1;  js(2) = b(jb,ib)%J(k)  ;
          is(3) = b(jb,ib)%I(k)+1;  js(3) = b(jb,ib)%J(k)+1;
          is(4) = b(jb,ib)%I(k)  ;  js(4) = b(jb,ib)%J(k)+1;
          !-----------------setup cell corner coordinates and adjust for periodicity
          DO l=1,4
            !---------------------apply index closure
            IF ( mod(iclo,2).EQ.0 ) &
                 is(l) = lbx + mod(nx - 1 + mod(is(l) - lbx + 1, nx), nx)
            IF ( mod(iclo,3).EQ.0 ) &
                 js(l) = lby + mod(ny - 1 + mod(js(l) - lby + 1, ny), ny)
            IF ( iclo.EQ.iclo_trpl .AND. js(l).GT.uby ) THEN
              is(l) = ubx + lbx - is(l)
              js(l) = 2*uby - js(l) + 1
            END IF
            !---------------------copy cell vertex coordinates into local variables
            IF ( ijg ) THEN
              IF ( gkind.EQ.4 ) THEN
                xs(l) = xg4(is(l),js(l));  ys(l) = yg4(is(l),js(l));
              ELSE
                xs(l) = xg8(is(l),js(l));  ys(l) = yg8(is(l),js(l));
              END IF
            ELSE
              IF ( gkind.EQ.4 ) THEN
                xs(l) = xg4(js(l),is(l));  ys(l) = yg4(js(l),is(l));
              ELSE
                xs(l) = xg8(js(l),is(l));  ys(l) = yg8(js(l),is(l));
              END IF
            END IF
            !---------------------shift longitudes to same range
            IF ( llg ) THEN
              xs(l) = mod(xs(l),real(d360,8))
              IF ( lclo .OR. l360 ) THEN
                IF ( xs(l).LT.zero ) xs(l) = xs(l) + d360
              ELSE
                IF ( xs(l).GT.d180 ) xs(l) = xs(l) - d360
              END IF
            END IF
          END DO !L
          !-----------------check cell distance from target point
          xsm = sum(xs)/four; ysm = sum(ys)/four;
          dd = w3dist(llg,xt,yt,xsm,ysm)
          IF ( ldbg ) &
               WRITE(*,'(A,5I6,3E24.16,4(/A,1I1,A,2I6,2E24.16))') &
               'W3GFCL_R8 - CHECK CELL:',lvl,n,ib,jb,k,xsm,ysm,dd, &
               ('          CORNER(',l,'):',is(l),js(l),xs(l),ys(l),l=1,4)
          IF (dd.LT.dd1) THEN
            lvl1   = lvl
            n1     = n
            ib1    = ib
            jb1    = jb
            k1     = k
            dd1    = dd
            is1(:) = is(:)
            js1(:) = js(:)
            xs1(:) = xs(:)
            ys1(:) = ys(:)
          ENDIF
          found = .true.
        END DO cell_loop2
      END DO nnbr_loop
      IF ( found ) nlevel = nlevel + 1
      IF ( nlevel .GE. max_fncl_level ) EXIT level_loop
    END DO level_loop
    !
    !-----return cell that is shortest distance from target point
    is(:) = is1(:)
    js(:) = js1(:)
    xs(:) = xs1(:)
    ys(:) = ys1(:)
    IF ( ldbg ) &
         WRITE(*,'(A,5I6,1E24.16,4(/A,1I1,A,2I6,2E24.16))') &
         'W3GFCL_R8 - CLOSEST CELL:',lvl1,n1,ib1,jb1,k1,dd1, &
         ('          CORNER(',l,'):',is(l),js(l),xs(l),ys(l),l=1,4)
    !
    !-----check if cell includes a pole or branch cut
    IF ( llg ) THEN
      n = 0
      !---------count longitudinal branch cut crossings
      DO i=1,4
        j = mod(i,4) + 1
        IF ( abs(xs(j)-xs(i)) .GT. d180 ) n = n + 1
      END DO
      !---------single longitudinal branch cut crossing
      !         or single vertex at 90 degrees => cell includes pole
      lplc = n.EQ.1 .OR. count(abs(ys).EQ.d90).EQ.1
      IF ( lplc .AND. ldbg ) &
           WRITE(*,'(A)') 'W3GFCL_R8 - CELL INCLUDES A POLE'
    ELSE
      lplc = .false.
    END IF
    IF ( PRESENT(pole) ) pole = lplc
 
  END FUNCTION w3gfcl_r8
  !/
  !/ End of W3GFCL ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3GFCD_R4( GSU, XT, YT, IS, JS, XS, YS, POLE, EPS, DEBUG ) &
  !/    RESULT(INGRID)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Find cell in grid, associated with the input grid-search-utility
  !     object (GSU), that encloses the target point (xt,yt), using direct
  !     grid search (i.e., no bucket search).
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Return parameter
  !     ----------------------------------------------------------------
  !       INGRID  Log.   O   Logical flag indicating if target point lies
  !                          within the source grid domain.
  !     ----------------------------------------------------------------
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       GSU     Type   I   Grid-search-utility object.
  !       XT      Real   I   X-coordinate of target point.
  !       YT      Real   I   Y-coordinate of target point.
  !       IS,JS   I.A.   O   (I,J) indices of vertices of enclosing grid cell.
  !       XS,YS   R.A.   O   (X,Y) coord. of vertices of enclosing grid cell.
  !       POLE    Log.   O   OPTIONAL logical flag to indicate whether or not
  !                          the enclosing grid cell includes a pole.
  !       EPS     Real   I   OPTIONAL small non-zero tolerance used to check if
  !                          target point is in domain and for point coincidence.
  !       DEBUG   Log.   I   OPTIONAL logical flag to turn on debug mode.
  !                          Default is FALSE.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !     - Check on previous creation of grid-search-utility object.
  !
  !  7. Remarks :
  !
  !     - The target point coordinates may be modified by this routine.
  !     - The target point longitude will be shifted to the source grid
  !       longitudinal range.
  !     - If enclosing cell includes a branch cut, then the coordinates of
  !       of the cell vertices AND the target point will be adjusted so
  !       that the branch cut is shifted 180 degrees.
  !
  !  8. Structure :
  !
  !     -----------------------------------------------------------------
  !      1.  Test input
  !      2.  Initialize search
  !      3.  Search for enclosing cell
  !     -----------------------------------------------------------------
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gfcd_r4( GSU, XT, YT, IS, JS, XS, YS, &
       POLE, EPS, DEBUG ) RESULT(INGRID)
    !     Single precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(4), INTENT(INOUT)  :: xt
    REAL(4), INTENT(INOUT)  :: yt
    INTEGER, INTENT(INOUT)  :: is(4), js(4)
    REAL(4), INTENT(INOUT)  :: xs(4), ys(4)
    LOGICAL, INTENT(OUT),OPTIONAL :: pole
    REAL(4), INTENT(IN), OPTIONAL :: eps
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    REAL(8) :: xt8, yt8, xs8(4), ys8(4), eps8
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GFCD_R4')
#endif
    !
    !-----set inputs
    xt8 = xt; yt8 = yt;
    IF ( PRESENT(eps) ) THEN
      eps8 = eps
    ELSE
      eps8 = eps_default
    END IF
    !
    !-----call double precision method
    ingrid = w3gfcd( gsu, xt8, yt8, is, js, xs8, ys8, pole=pole, &
         eps=eps8, debug=debug )
    !
    !-----set outputs
    xt = xt8; yt = yt8;
    xs = xs8; ys = ys8;
 
  END FUNCTION w3gfcd_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gfcd_r8( GSU, XT, YT, IS, JS, XS, YS, &
       POLE, EPS, DEBUG ) RESULT(INGRID)
    !     Double precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(8), INTENT(INOUT)  :: xt
    REAL(8), INTENT(INOUT)  :: yt
    INTEGER, INTENT(INOUT)  :: is(4), js(4)
    REAL(8), INTENT(INOUT)  :: xs(4), ys(4)
    LOGICAL, INTENT(OUT),OPTIONAL :: pole
    REAL(8), INTENT(IN), OPTIONAL :: eps
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    REAL(8) :: leps
    LOGICAL :: ldbg, lplc
    INTEGER :: i, j, l
    LOGICAL :: ijg, llg, lclo, l360
    INTEGER :: iclo, gkind
    INTEGER :: lbx, lby, ubx, uby, nx, ny
    INTEGER :: lxc, lyc, uxc, uyc
    REAL(4), POINTER :: xg4(:,:), yg4(:,:)
    REAL(8), POINTER :: xg8(:,:), yg8(:,:)
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GFCD_R8')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Test input
    !
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/2A/)') 'W3GFCD_R8 ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
    IF ( PRESENT(eps) ) THEN
      IF ( eps .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GFCD_R8 ERROR -- ', &
             'EPS parameter must be >= 0'
        CALL extcde (1)
      END IF
      leps = eps
    ELSE
      leps = eps_default
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Initialize search
    !
    IF ( PRESENT(debug) ) THEN
      ldbg = debug
    ELSE
      ldbg = .false.
    END IF
    !
    !  Local pointers to grid search utility object data
    ijg = gsu%PTR%IJG
    llg = gsu%PTR%LLG
    iclo = gsu%PTR%ICLO
    lclo = gsu%PTR%LCLO
    l360 = gsu%PTR%L360
    gkind = gsu%PTR%GKIND
    lbx = gsu%PTR%LBX;  lby = gsu%PTR%LBY;
    ubx = gsu%PTR%UBX;  uby = gsu%PTR%UBY;
    nx = gsu%PTR%NX;  ny = gsu%PTR%NY;
    IF ( gkind.EQ.4 ) THEN
      xg4 => gsu%PTR%XG4;  yg4 => gsu%PTR%YG4;
    ELSE
      xg8 => gsu%PTR%XG8;  yg8 => gsu%PTR%YG8;
    END IF
    !
    ingrid = .false.
    !
    !  Shift target to appropriate longitude range
    IF ( llg ) THEN
      xt = mod(xt,real(d360,8))
      IF ( lclo .OR. l360 ) THEN
        IF ( xt.LT.zero ) xt = xt + d360
      ELSE
        IF ( xt.GT.d180 ) xt = xt - d360
      END IF
    END IF
    IF ( ldbg ) &
         WRITE(*,'(/A,2E24.16)') 'W3GFCD_R8 - TARGET POINT:',xt,yt
 
    !-----number of cells
    lxc = lbx;  lyc = lby;
    SELECT CASE ( iclo )
    CASE ( iclo_none )
      uxc = ubx-1;  uyc = uby-1;
    CASE ( iclo_grdi )
      uxc = ubx;    uyc = uby-1;
    CASE ( iclo_grdj )
      uxc = ubx-1;  uyc = uby;
    CASE ( iclo_trdl )
      uxc = ubx;    uyc = uby;
    CASE ( iclo_trpl )
      uxc = ubx;    uyc = uby;
    END SELECT
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Search for enclosing cell
    !
    cell_loop: DO i=lxc,uxc
      DO j=lyc,uyc
        !-------------create list of cell vertices
        is(1) = i  ;  js(1) = j  ;
        is(2) = i+1;  js(2) = j  ;
        is(3) = i+1;  js(3) = j+1;
        is(4) = i  ;  js(4) = j+1;
        !-------------setup cell corner coordinates and adjust for periodicity
        DO l=1,4
          !-----------------apply index closure
          IF ( mod(iclo,2).EQ.0 ) &
               is(l) = lbx + mod(nx - 1 + mod(is(l) - lbx + 1, nx), nx)
          IF ( mod(iclo,3).EQ.0 ) &
               js(l) = lby + mod(ny - 1 + mod(js(l) - lby + 1, ny), ny)
          IF ( iclo.EQ.iclo_trpl .AND. js(l).GT.uby ) THEN
            is(l) = ubx + lbx - is(l)
            js(l) = 2*uby - js(l) + 1
          END IF
          !-----------------copy cell vertex coordinates into local variables
          IF ( ijg ) THEN
            IF ( gkind.EQ.4 ) THEN
              xs(l) = xg4(is(l),js(l));  ys(l) = yg4(is(l),js(l));
            ELSE
              xs(l) = xg8(is(l),js(l));  ys(l) = yg8(is(l),js(l));
            END IF
          ELSE
            IF ( gkind.EQ.4 ) THEN
              xs(l) = xg4(js(l),is(l));  ys(l) = yg4(js(l),is(l));
            ELSE
              xs(l) = xg8(js(l),is(l));  ys(l) = yg8(js(l),is(l));
            END IF
          END IF
          !-----------------shift longitudes to same range
          IF ( llg ) THEN
            xs(l) = mod(xs(l),real(d360,8))
            IF ( lclo .OR. l360 ) THEN
              IF ( xs(l).LT.zero ) xs(l) = xs(l) + d360
            ELSE
              IF ( xs(l).GT.d180 ) xs(l) = xs(l) - d360
            END IF
          END IF
        END DO !L
        IF ( ldbg ) &
             WRITE(*,'(A,4(/A,1I1,A,2I6,2E24.16))') &
             'W3GFCD_R8 - CHECK CELL:', &
             ('          CORNER(',l,'):',is(l),js(l),xs(l),ys(l),l=1,4)
        !-------------check if point is enclosed in cell defined by xs(1:4) & ys(1:4)
        ingrid = w3ckcl(llg,xt,yt,4,xs,ys,lplc,leps,ldbg)
        IF ( ldbg ) WRITE(*,'(A,1L2)')'W3GFCD_R8 - INGRID:',ingrid
        IF ( ingrid ) THEN
          !-----------------exit search
          IF ( ldbg ) &
               WRITE(*,'(A,4(2I6))') &
               'W3GFCD_R8 - ENCLOSING CELL:',(is(l),js(l),l=1,4)
          IF ( PRESENT(pole) ) pole = lplc
          EXIT cell_loop
        END IF !point in cell
      END DO !J
    END DO cell_loop
 
  END FUNCTION w3gfcd_r8
  !/
  !/ End of W3GFCD ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3GFPT( GSU, XTIN, YTIN, IX, IY, EPS, DCIN, DEBUG ) &
  !/    RESULT(INGRID)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Find point in grid, associated with the input grid-search-utility
  !     object (GSU), that is closest to the target point (xtin,ytin).
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Return parameter
  !     ----------------------------------------------------------------
  !       INGRID  Log.   O   Logical flag indicating if target point lies
  !                          within the source grid domain.
  !     ----------------------------------------------------------------
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       GSU     Type   I   Grid-search-utility object.
  !       XTIN    Real   I   X-coordinate of target point.
  !       YTIN    Real   I   Y-coordinate of target point.
  !       IX,JX   I.A.   O   (I,J) indices of nearest grid point.
  !       EPS     Real   I   OPTIONAL small non-zero tolerance used to check if
  !                          target point is in domain and for point coincidence.
  !       DCIN    Real   I   OPTIONAL distance outside of source grid in
  !                          units of cell width to treat target point as
  !                          inside the source grid.
  !                          Default is 0.
  !       DEBUG   Log.   I   OPTIONAL logical flag to turn on debug mode.
  !                          Default is FALSE.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !     - Check on previous initialization of grid search utility object.
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !     -----------------------------------------------------------------
  !      1.  Test input
  !      2.  Initialize search
  !      3.  Find enclosing cell and compute closest point
  !     -----------------------------------------------------------------
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gfpt_r4( GSU, XTIN, YTIN, IX, IY, EPS, DCIN, DEBUG ) &
       result(ingrid)
    !     Single precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(4), INTENT(IN)     :: xtin
    REAL(4), INTENT(IN)     :: ytin
    INTEGER, INTENT(OUT)    :: ix, iy
    REAL(4), INTENT(IN), OPTIONAL :: eps
    REAL(4), INTENT(IN), OPTIONAL :: dcin
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    REAL(8) :: xt8, yt8, eps8, dcin8
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GFPT_R4')
#endif
    !
    !-----set inputs
    xt8 = xtin; yt8 = ytin;
    IF ( PRESENT(eps) ) THEN
      eps8 = eps
    ELSE
      eps8 = eps_default
    END IF
    IF ( PRESENT(dcin) ) THEN
      dcin8 = dcin
    ELSE
      dcin8 = zero
    END IF
    !
    !-----call double precision method
    ingrid = w3gfpt( gsu, xt8, yt8, ix, iy, eps=eps8, dcin=dcin8, &
         debug=debug )
 
  END FUNCTION w3gfpt_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gfpt_r8( GSU, XTIN, YTIN, IX, IY, EPS, DCIN, DEBUG ) &
       result(ingrid)
    !     Single precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(8), INTENT(IN)     :: xtin
    REAL(8), INTENT(IN)     :: ytin
    INTEGER, INTENT(OUT)    :: ix, iy
    REAL(8), INTENT(IN), OPTIONAL :: eps
    REAL(8), INTENT(IN), OPTIONAL :: dcin
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    REAL(8), PARAMETER :: big = 1d16
    REAL(8) :: leps, ldcin
    LOGICAL :: ldbg, fncl
    INTEGER :: i, l
    INTEGER :: is(4), js(4)
    REAL(8) :: xt, yt, xs(4), ys(4)
    REAL(8) :: xtc, ytc, xsc(4), ysc(4)
    REAL(8) :: ixr, jxr, dd, lon0, lat0, dmin
    LOGICAL :: ijg, llg
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GFPT_R8')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Test input
    !
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/2A/)') 'W3GFPT_R8 ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
    IF ( PRESENT(eps) ) THEN
      IF ( eps .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GFPT_R8 ERROR -- ', &
             'EPS parameter must be >= 0'
        CALL extcde (1)
      END IF
      leps = eps
    ELSE
      leps = eps_default
    END IF
    IF ( PRESENT(dcin) ) THEN
      IF ( dcin .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GFPT_R8 ERROR -- ', &
             'DCIN parameter must be >= 0'
        CALL extcde (1)
      END IF
      ldcin = dcin
    ELSE
      ldcin = zero
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Initialize search
    !
    IF ( PRESENT(debug) ) THEN
      ldbg = debug
    ELSE
      ldbg = .false.
    END IF
    !
    !  Local pointers to grid search utility object data
    ijg = gsu%PTR%IJG
    llg = gsu%PTR%LLG
    !
    ingrid = .false.
    ix = gsu%PTR%LBX-1
    iy = gsu%PTR%LBY-1
    !
    xt = xtin;  yt = ytin;
    IF ( ldbg ) &
         WRITE(*,'(/A,2E24.16)') 'W3GFPT_R8 - TARGET POINT:',xt,yt
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Find enclosing cell and compute closest point
    !
    fncl = ldcin .GT. zero
    ingrid = w3gfcl( gsu, xt, yt, is, js, xs, ys, eps=leps, fncl=fncl, debug=ldbg )
    IF ( .NOT.ingrid .AND. .NOT.fncl ) RETURN
    !
    !-----Set in grid if point is within DCIN cell width distance of closest cell
    IF ( .NOT.ingrid .AND. fncl ) THEN
      !-------Compute cell relative index space location
      lon0 = sum(xs)/four; lat0 = sum(ys)/four;
      IF ( d90-abs(lat0).GT.near_pole ) THEN
        !-----------non-pole cell: compute relative location using (lon,lat)
        CALL getpqr(xt,yt,xs,ys,ixr,jxr,eps=leps,debug=ldbg)
      ELSE
        !-----------pole cell: compute relative location using stereographic projection
        CALL w3splx(lon0,lat0,zero,xt,yt,xtc,ytc)
        DO i=1,4
          CALL w3splx(lon0,lat0,zero,xs(i),ys(i),xsc(i),ysc(i))
        END DO
        CALL getpqr(xtc,ytc,xsc,ysc,ixr,jxr,eps=leps,debug=ldbg)
      ENDIF
      dd = half + ldcin
      ingrid = abs(ixr-half).LE.dd .AND. abs(jxr-half).LE.dd
    END IF
    !
    !-----Compute indices of closest point in cell
    IF ( ingrid ) THEN
      dmin = big
      DO l=1,4
        dd = w3dist( llg, xt, yt, xs(l), ys(l) )
        IF ( dd .LT. dmin ) THEN
          dmin = dd;  ix = is(l);  iy = js(l);
        END IF
      END DO !L
    END IF
 
  END FUNCTION w3gfpt_r8
  !/
  !/ End of W3GFPT ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3GFIJ( GSU, XTIN, YTIN, IX, JX, EPS, DCIN, DEBUG ) &
  !/    RESULT(INGRID)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute coordinates ( ix, jx ) of target point ( xtin, ytin ) in
  !     source grid index space from source grid associated with the input
  !     grid search utility object (GSU).
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Return parameter
  !     ----------------------------------------------------------------
  !       INGRID  Log.   O   Logical flag indicating if target point lies
  !                          within the source grid domain.
  !     ----------------------------------------------------------------
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       GSU     Type   I   Grid-search-utility object.
  !       XTIN    Real   I   X-coordinate of target point.
  !       YTIN    Real   I   Y-coordinate of target point.
  !       IX      Real   O   X-coordinate of target point in source grid
  !                          index space.
  !       JX      Real   O   Y-coordinate of target point in source grid
  !                          index space.
  !       EPS     Real   I   OPTIONAL small non-zero tolerance used to check if
  !                          target point is in domain and for point coincidence.
  !       DCIN    Real   I   OPTIONAL distance outside of source grid in
  !                          units of cell width to treat target point as
  !                          inside the source grid.
  !                          Default is 0.
  !       DEBUG   Log.   I   OPTIONAL logical flag to turn on debug mode.
  !                          Default is FALSE.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !     - Check on previous initialization of grid search utility object.
  !     - Check on appropriate input of optional arguments.
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !     -----------------------------------------------------------------
  !      1.  Test input
  !      2.  Initialize search
  !      3.  Find enclosing cell and compute index coordinates
  !     -----------------------------------------------------------------
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gfij_r4( GSU, XTIN, YTIN, IX, JX, EPS, DCIN, DEBUG ) &
       result(ingrid)
    !     Single precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(4), INTENT(IN)     :: xtin
    REAL(4), INTENT(IN)     :: ytin
    REAL(4), INTENT(OUT)    :: ix
    REAL(4), INTENT(OUT)    :: jx
    REAL(4), INTENT(IN), OPTIONAL :: eps
    REAL(4), INTENT(IN), OPTIONAL :: dcin
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    REAL(8) :: xt8, yt8, ix8, jx8, eps8, dcin8
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GFIJ_R4')
#endif
    !
    !-----set inputs
    xt8 = xtin; yt8 = ytin;
    IF ( PRESENT(eps) ) THEN
      eps8 = eps
    ELSE
      eps8 = eps_default
    END IF
    IF ( PRESENT(dcin) ) THEN
      dcin8 = dcin
    ELSE
      dcin8 = zero
    END IF
    !
    !-----call double precision method
    ingrid = w3gfij( gsu, xt8, yt8, ix8, jx8, eps=eps8, dcin=dcin8, &
         debug=debug )
    !
    !-----set outputs
    ix = ix8; jx = jx8;
 
  END FUNCTION w3gfij_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3gfij_r8( GSU, XTIN, YTIN, IX, JX, EPS, DCIN, DEBUG ) &
       result(ingrid)
    !     Double precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(8), INTENT(IN)     :: xtin
    REAL(8), INTENT(IN)     :: ytin
    REAL(8), INTENT(OUT)    :: ix
    REAL(8), INTENT(OUT)    :: jx
    REAL(8), INTENT(IN), OPTIONAL :: eps
    REAL(8), INTENT(IN), OPTIONAL :: dcin
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    REAL(8) :: leps, ldcin
    INTEGER :: i
    LOGICAL :: ldbg, fncl, pole
    INTEGER :: is(4), js(4)
    REAL(8) :: xt, yt, xs(4), ys(4)
    REAL(8) :: xtc, ytc, xsc(4), ysc(4)
    REAL(8) :: ixr, jxr, dd, lon0, lat0
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GFIJ_R8')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Test input
    !
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/2A/)') 'W3GFIJ_R8 ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
    IF ( PRESENT(eps) ) THEN
      IF ( eps .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GFIJ_R8 ERROR -- ', &
             'EPS parameter must be >= 0'
        CALL extcde (1)
      END IF
      leps = eps
    ELSE
      leps = eps_default
    END IF
    IF ( PRESENT(dcin) ) THEN
      IF ( dcin .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GFIJ_R8 ERROR -- ', &
             'DCIN parameter must be >= 0'
        CALL extcde (1)
      END IF
      ldcin = dcin
    ELSE
      ldcin = zero
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Initialize search
    !
    IF ( PRESENT(debug) ) THEN
      ldbg = debug
    ELSE
      ldbg = .false.
    END IF
    !
    xt = xtin;  yt = ytin;
    IF ( ldbg ) WRITE(*,'(/A,2E24.16)') 'W3GFIJ_R8 - TARGET POINT:',xt,yt
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Find enclosing cell and compute point location
    !
    fncl = ldcin .GT. zero
    ingrid = w3gfcl(gsu,xt,yt,is,js,xs,ys,pole=pole,eps=leps,fncl=fncl,debug=ldbg)
    IF ( .NOT.ingrid .AND. .NOT.fncl ) RETURN
    !
    !-----Compute cell relative index space location
    lon0 = sum(xs)/four; lat0 = sum(ys)/four;
    IF ( d90-abs(lat0).GT.near_pole ) THEN
      !---------non-pole cell: compute relative location using (lon,lat)
      CALL getpqr(xt,yt,xs,ys,ixr,jxr,eps=leps,debug=ldbg)
    ELSE
      !---------pole cell: compute relative location using stereographic projection
      CALL w3splx(lon0,lat0,zero,xt,yt,xtc,ytc)
      DO i=1,4
        CALL w3splx(lon0,lat0,zero,xs(i),ys(i),xsc(i),ysc(i))
      END DO
      CALL getpqr(xtc,ytc,xsc,ysc,ixr,jxr,eps=leps,debug=ldbg)
    ENDIF
    IF ( ldbg ) &
         WRITE(*,'(A,2L2,2E24.16)') 'W3GFIJ_R8 - RELATIVE:',ingrid,fncl,ixr,jxr
    !
    !-----Set in grid if point is within DCIN cell width distance of closest cell
    IF ( .NOT.ingrid .AND. fncl ) THEN
      dd = half + ldcin
      ingrid = abs(ixr-half).LE.dd .AND. abs(jxr-half).LE.dd
    END IF
    !
    !-----Compute absolute index space location
    ix = is(1)+ixr;  jx = js(1)+jxr;
    IF ( ldbg ) &
         WRITE(*,'(A,2L2,2E24.16)') 'W3GFIJ_R8 - ABSOLUTE:',ingrid,fncl,ix,jx
 
  END FUNCTION w3gfij_r8
  !/
  !/ End of W3GFIJ ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3GRMP( GSU, XTIN, YTIN, IS, JS, RW, EPS, &
  !/                     DCIN, MASK, MSKC, NNBR, DEBUG ) RESULT(INGRID)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute bilinear remapping for target point (xtin,ytin) from source
  !     grid associated with the input grid search utility object (GSU).
  !     The indices of the source points used for remapping are returned in
  !     is(1:4) and js(1:4).  The remapping weights are returned in rw(1:4).
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Return parameter
  !     ----------------------------------------------------------------
  !       INGRID  Log.   O   Logical flag indicating if target point lies
  !                          within the source grid domain.
  !     ----------------------------------------------------------------
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       GSU     Type   I   Grid-search-utility object.
  !       XTIN    Real   I   X-coordinate of target point.
  !       YTIN    Real   I   Y-coordinate of target point.
  !       IS,JS   I.A.   O   (I,J) indices of vertices of enclosing grid cell.
  !       RW      R.A.   O   Array of interpolation weights.
  !       EPS     Real   I   OPTIONAL small non-zero tolerance used to check if
  !                          target point is in domain and for point coincidence.
  !       DCIN    Real   I   OPTIONAL distance outside of source grid in
  !                          units of cell width to treat target point as
  !                          inside the source grid.  Default is 0.
  !       MASK    L.A.   I   OPTIONAL logical mask for source grid.
  !       MSKC    Int.   O   OPTIONAL output integer parameter indicating how
  !                          the enclosing cell is masked.  Possible values
  !                          are MSKC_NONE, MSKC_PART and MSKC_FULL.
  !                          MSKC is required when MASK is specified.
  !       NNBR    Int.   I/O OPTIONAL integer parameter indicating the number
  !                          of nearest-neighbor non-masked points used for
  !                          distance-weighted averaging.
  !                          Input:  Requested number of nearest-neighbor
  !                                  non-masked points (0 < NNBR <= 4).
  !                          Output: Actual number of nearest-neighbor
  !                                  non-masked points used.
  !       DEBUG   Log.   I   OPTIONAL logical flag to turn on debug mode.
  !                          Default is FALSE.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !     - Check on previous initialization of grid search utility object.
  !     - Check on appropriate input of optional arguments.
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !     -----------------------------------------------------------------
  !      1.  Test input
  !      2.  Initialize search
  !      3.  Find enclosing cell and compute remapping weights
  !          - if enclosing cell does not includes a pole, then
  !            compute bilinear remapping
  !          - if enclosing cell includes a pole, then
  !            compute distance weighted remapping
  !      4.  Handle case of target point located within a partially masked cell.
  !      5.  Handle case of target point located within a fully masked cell.
  !     -----------------------------------------------------------------
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3grmp_r4( GSU, XTIN, YTIN, IS, JS, RW, EPS, &
       DCIN, MASK, MSKC, NNBR, DEBUG ) RESULT(INGRID)
    !     Single precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(4), INTENT(IN)     :: xtin
    REAL(4), INTENT(IN)     :: ytin
    INTEGER, INTENT(OUT)    :: is(4)
    INTEGER, INTENT(OUT)    :: js(4)
    REAL(4), INTENT(OUT)    :: rw(4)
    REAL(4), INTENT(IN)   , OPTIONAL :: eps
    REAL(4), INTENT(IN)   , OPTIONAL :: dcin
    LOGICAL, INTENT(IN)   , OPTIONAL :: mask(:,:)
    INTEGER, INTENT(OUT)  , OPTIONAL :: mskc
    INTEGER, INTENT(INOUT), OPTIONAL :: nnbr
    LOGICAL, INTENT(IN)   , OPTIONAL :: debug
 
    !     Local parameters
    REAL(8) :: xt8, yt8, rw8(4), eps8, dcin8
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GRMP_R4')
#endif
    !
    !-----set inputs
    xt8 = xtin; yt8 = ytin;
    IF ( PRESENT(eps) ) THEN
      eps8 = eps
    ELSE
      eps8 = eps_default
    END IF
    IF ( PRESENT(dcin) ) THEN
      dcin8 = dcin
    ELSE
      dcin8 = zero
    END IF
    !
    !-----call double precision method
    ingrid = w3grmp( gsu, xt8, yt8, is, js, rw8, &
         eps=eps8, dcin=dcin8, &
         mask=mask, mskc=mskc, nnbr=nnbr, debug=debug )
    !
    !-----set outputs
    rw = rw8
 
  END FUNCTION w3grmp_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3grmp_r8( GSU, XTIN, YTIN, IS, JS, RW, EPS, &
       DCIN, MASK, MSKC, NNBR, DEBUG ) RESULT(INGRID)
    !     Double precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(8), INTENT(IN)     :: xtin
    REAL(8), INTENT(IN)     :: ytin
    INTEGER, INTENT(OUT)    :: is(4)
    INTEGER, INTENT(OUT)    :: js(4)
    REAL(8), INTENT(OUT)    :: rw(4)
    REAL(8), INTENT(IN)   , OPTIONAL :: eps
    REAL(8), INTENT(IN)   , OPTIONAL :: dcin
    LOGICAL, INTENT(IN)   , OPTIONAL :: mask(:,:)
    INTEGER, INTENT(OUT)  , OPTIONAL :: mskc
    INTEGER, INTENT(INOUT), OPTIONAL :: nnbr
    LOGICAL, INTENT(IN)   , OPTIONAL :: debug
 
    !     Local parameters
    REAL(8), PARAMETER :: big = 1d16
    REAL(8), PARAMETER :: small = 1d-6
    REAL(8) :: leps
    LOGICAL :: ldbg, fncl, pole
    INTEGER :: i, j, l
    LOGICAL :: m, msk(4)
    INTEGER :: lvl, n, ns, icc, jcc
    REAL(8) :: xt, yt, xs(4), ys(4), dw(4)
    REAL(8) :: xtc, ytc, xsc(4), ysc(4)
    REAL(8) :: ldcin, ixr, jxr, x, y, d(4), dd, dmin, dsum, lon0, lat0
    LOGICAL :: ijg, llg, lclo
    INTEGER :: iclo, gkind
    INTEGER :: lbx, lby, ubx, uby, nx, ny
    REAL(4), POINTER :: xg4(:,:), yg4(:,:)
    REAL(8), POINTER :: xg8(:,:), yg8(:,:)
    TYPE(t_nns), POINTER :: nnp
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GRMP_R8')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Test input
    !
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
    !
    IF ( PRESENT(eps) ) THEN
      IF ( eps .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', &
             'EPS parameter must be >= 0'
        CALL extcde (1)
      END IF
      leps = eps
    ELSE
      leps = eps_default
    END IF
    !
    IF ( PRESENT(dcin) ) THEN
      IF ( dcin .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GRMP_R4 ERROR -- ', &
             'DCIN parameter must be >= 0'
        CALL extcde (1)
      END IF
      ldcin = dcin
    ELSE
      ldcin = zero
    END IF
    !
    IF ( PRESENT(mask) ) THEN
      IF ( .NOT.PRESENT(mskc) ) THEN
        WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', &
             'MSKC must be specified with MASK'
        CALL extcde (1)
      END IF
      IF ( PRESENT(nnbr) ) THEN
        IF ( .NOT.ASSOCIATED(gsu%PTR%NNP) ) THEN
          WRITE(0,'(/3A/)') 'W3GRMP_R8 ERROR -- ', &
               'MASK and NNBR input specified, ', &
               'but grid point-search object not created'
          CALL extcde (1)
        END IF
        IF ( nnbr .LE. 0 .OR. nnbr .GT. 4 ) THEN
          WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', &
               'NNBR must be >= 1 AND <= 4'
          CALL extcde (1)
        END IF
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Initialize search
    !
    IF ( PRESENT(debug) ) THEN
      ldbg = debug
    ELSE
      ldbg = .false.
    END IF
    !
    !  Local pointers to grid search utility object data
    ijg = gsu%PTR%IJG
    llg = gsu%PTR%LLG
    iclo = gsu%PTR%ICLO
    lclo = gsu%PTR%LCLO
    gkind = gsu%PTR%GKIND
    lbx = gsu%PTR%LBX;  lby = gsu%PTR%LBY;
    ubx = gsu%PTR%UBX;  uby = gsu%PTR%UBY;
    nx = gsu%PTR%NX;  ny = gsu%PTR%NY;
    IF ( gkind.EQ.4 ) THEN
      xg4 => gsu%PTR%XG4;  yg4 => gsu%PTR%YG4;
    ELSE
      xg8 => gsu%PTR%XG8;  yg8 => gsu%PTR%YG8;
    END IF
    nnp => gsu%PTR%NNP
    !
    IF ( PRESENT(mask) ) THEN
      IF ( ijg ) THEN
        IF ( .NOT.(ubound(mask,1).EQ.nx.AND. &
             ubound(mask,2).EQ.ny) ) THEN
          WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', &
               'MASK array size does not agree with GSU index bounds'
          CALL extcde (1)
        END IF
      ELSE
        IF ( .NOT.(ubound(mask,2).EQ.nx.AND. &
             ubound(mask,1).EQ.ny) ) THEN
          WRITE(0,'(/2A/)') 'W3GRMP_R8 ERROR -- ', &
               'MASK array size does not agree with GSU index bounds'
          CALL extcde (1)
        END IF
      END IF
    END IF
    !
    rw = zero;
    !
    xt = xtin;  yt = ytin;
    IF ( ldbg ) WRITE(*,'(/A,2E24.16)') 'W3GRMP_R8 - TARGET POINT:',xt,yt
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Find enclosing cell and compute remapping
    !
    fncl = ldcin .GT. zero
    ingrid = w3gfcl(gsu,xt,yt,is,js,xs,ys,pole=pole,eps=leps,fncl=fncl,debug=ldbg)
    IF ( .NOT.ingrid .AND. .NOT.fncl ) RETURN
    !
    !-----Compute remapping
    lon0 = sum(xs)/four; lat0 = sum(ys)/four;
    IF ( d90-abs(lat0).GT.near_pole ) THEN
      !---------non-pole cell: compute remapping using (lon,lat)
      CALL getpqr(xt,yt,xs,ys,ixr,jxr,eps=leps,debug=ldbg)
    ELSE
      !---------pole cell: compute remapping using stereographic projection
      CALL w3splx(lon0,lat0,zero,xt,yt,xtc,ytc)
      DO i=1,4
        CALL w3splx(lon0,lat0,zero,xs(i),ys(i),xsc(i),ysc(i))
      END DO
      CALL getpqr(xtc,ytc,xsc,ysc,ixr,jxr,eps=leps,debug=ldbg)
    ENDIF
    dw(1) = (one-ixr)*(one-jxr)
    dw(2) = ixr*(one-jxr)
    dw(3) = ixr*jxr
    dw(4) = (one-ixr)*jxr
    rw = dw
    IF ( ldbg ) THEN
      WRITE(*,'(A,2E24.16)') 'W3GRMP_R8 - REMAP (TGT):',xt,yt
      DO l=1,4
        WRITE(*,'(A,3I6,E24.16)') 'W3GRMP_R8 - REMAP (SRC):', &
             l,is(l),js(l),dw(l)
      END DO
    END IF !LDBG
    !
    !-----Set in grid if point is within DCIN cell width distance of closest cell
    IF ( .NOT.ingrid .AND. fncl ) THEN
      dd = half + ldcin
      ingrid = abs(ixr-half).LE.dd .AND. abs(jxr-half).LE.dd
    END IF
    IF ( .NOT.ingrid ) RETURN
    !
    IF ( .NOT.PRESENT(mask) ) RETURN
    !
    ! -------------------------------------------------------------------- /
    ! 4.  Handle case of target point located within a partially masked cell.
    !
    !-----copy cell mask values according to array ordering
    IF ( ijg ) THEN
      DO l=1,4
        msk(l) = mask(is(l)-lbx+1,js(l)-lby+1)
      END DO
    ELSE
      DO l=1,4
        msk(l) = mask(js(l)-lby+1,is(l)-lbx+1)
      END DO
    END IF
    !
    !-----adjust weights for a partially masked cell
    dsum = zero
    ns = 4
    DO l=1,4
      IF ( msk(l) ) THEN
        ns = ns - 1
        dw(l) = zero
      END IF
      dsum = dsum + dw(l)
    END DO
    IF ( ns .EQ. 4 ) THEN
      mskc = mskc_none
      RETURN
    END IF
    IF ( ns .GT. 0 .AND. dsum .GT. small ) THEN
      dw = dw / dsum
      rw = dw
      IF ( ldbg ) &
           WRITE(*,'(A,2E24.16,4(2I6,E24.16))') &
           'W3GRMP_R8 - PARTIAL MASKED CELL:', &
           xt,yt,(is(l),js(l),dw(l),l=1,4)
      mskc = mskc_part
      RETURN
    ELSE
      mskc = mskc_full
      IF ( .NOT.PRESENT(nnbr) ) RETURN
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 5.  Handle case of target point located within a fully masked cell.
    !
    !  Choose closest point in enclosing land cell to be the central point
    dmin = big
    DO l=1,4
      dd = w3dist(llg,xt,yt,xs(l),ys(l))
      IF ( dd .LT. dmin ) THEN
        dmin = dd;  icc = is(l);  jcc = js(l);
      END IF
    END DO !L
    !
    !  Search nearest-neighbor source points for closest nnbr un-masked
    !  points and compute distance-weighted average remapping.
    IF ( ldbg ) &
         WRITE(*,'(A,2I6)') &
         'W3GRMP_R8 - BEGIN POINT NNBR SEARCH:',icc,jcc
    ns = 0;  d(:) = big;
    level_loop: DO lvl=0,nnp%NLVL
      nnbr_loop: DO n=nnp%N1(lvl),nnp%N2(lvl)
        i = icc + nnp%DI(n);  j = jcc + nnp%DJ(n);
        IF ( iclo.EQ.iclo_none ) THEN
          IF ( i.LT.lbx .OR. i.GT.ubx ) cycle nnbr_loop
          IF ( j.LT.lby .OR. j.GT.uby ) cycle nnbr_loop
        END IF
        !-------------apply index closure
        IF ( mod(iclo,2).EQ.0 ) &
             i = lbx + mod(nx - 1 + mod(i - lbx + 1, nx), nx)
        IF ( mod(iclo,3).EQ.0 ) &
             j = lby + mod(ny - 1 + mod(j - lby + 1, ny), ny)
        IF ( iclo.EQ.iclo_trpl .AND. j.GT.uby ) THEN
          i = ubx + lbx - i
          j = 2*uby - j + 1
        END IF
        !-------------set mask
        IF ( ijg ) THEN
          m = mask(i-lbx+1,j-lby+1)
        ELSE
          m = mask(j-lby+1,i-lbx+1)
        END IF
        IF ( ldbg ) &
             WRITE(*,'(A,4I6,1L6)') &
             'W3GRMP_R8 - POINT NNBR SEARCH:',lvl,n,i,j,m
        !-------------if masked point, then skip
        IF ( m ) cycle nnbr_loop
        !-------------compute distance
        IF ( ijg ) THEN
          IF ( gkind.EQ.4 ) THEN
            x = xg4(i,j);  y = yg4(i,j);
          ELSE
            x = xg8(i,j);  y = yg8(i,j);
          END IF
        ELSE
          IF ( gkind.EQ.4 ) THEN
            x = xg4(j,i);  y = yg4(j,i);
          ELSE
            x = xg8(j,i);  y = yg8(j,i);
          END IF
        END IF
        dd = w3dist(llg,xt,yt,x,y)
        !-------------still need nnbr points
        IF ( ns .LT. nnbr ) THEN
          !-----------------add to list
          ns = ns + 1
          is(ns) = i;  js(ns) = j;  d(ns) = dd;
          !-----------------once list is full sort according to increasing distance
          IF ( ns .EQ. nnbr ) CALL w3sort(ns,is,js,d)
          !---------------we have found nnbr points
        ELSE !list is full
          !-----------------insert into list if the newest point is closer
          CALL w3isrt(i,j,dd,ns,is,js,d)
        END IF !list is full
        IF ( ldbg ) &
             WRITE(*,'(A,I2,I3,I6,4(2I6,E24.16))') &
             'W3GRMP_R8 - POINT NNBR LIST:', &
             lvl,n,ns,(is(l),js(l),d(l),l=1,ns)
      END DO nnbr_loop
      !---------if we have found nnbr_rqd points, then exit the search
      IF ( ns .EQ. nnbr ) EXIT level_loop
    END DO level_loop
    nnbr = ns
    !
    !  If zero unmasked points found, then return nnbr=0 as error indicator
    IF ( nnbr .EQ. 0 ) RETURN
    !
    !  Compute distance-weighted remapping for nnbr points
    dsum = zero
    DO l=1,nnbr
      dsum = dsum + one/(d(l)+small)
    END DO
    dw(1:nnbr) = one/(d(1:nnbr)+small)/dsum
    rw = dw
    IF ( ldbg ) THEN
      WRITE(*,'(A,2E24.16,I6)') &
           'W3GRMP_R8 - FULLY MASKED CELL (TGT):',xt,yt,nnbr
      DO l=1,nnbr
        WRITE(*,'(A,3I6,E24.16)') &
             'W3GRMP_R8 - FULLY MASKED CELL (SRC):', &
             l,is(l),js(l),dw(l)
      END DO
    END IF !LDBG
 
  END FUNCTION w3grmp_r8
  !/
  !/ End of W3GRMP ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3GRMC( GSU, XTIN, YTIN, RTYP, NS, IS, JS, CS, EPS, &
  !/                     DCIN, WDTH, MASK, NMSK, DEBUG ) RESULT(INGRID)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute remapping coefficients for target point (XTIN,YTIN) from
  !     source grid associated with the input grid search utility object
  !     (GSU). The type of remapping is specified by RTYP.  The indices
  !     of the source points used for remapping are returned in IS(1:NS)
  !     and JS(1:NS).  The remapping coefficients are returned in CS(1:NS).
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Return parameter
  !     ----------------------------------------------------------------
  !       INGRID  Log.   O   Logical flag indicating if target point lies
  !                          within the source grid domain.
  !     ----------------------------------------------------------------
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       GSU     Type   I   Grid-search-utility object.
  !       XTIN    Real   I   X-coordinate of target point.
  !       YTIN    Real   I   Y-coordinate of target point.
  !       RTYP    Str.   I   Remap type: 'nearpt', 'bilinr', 'bicubc',
  !                                      'filter'
  !       NS      Int.   O   Number of vertices for remapping
  !       IS,JS   I.A.   O   (I,J) indices of vertices for remapping
  !       CS      R.A.   O   Array of remapping coefficients
  !       EPS     Real   I   OPTIONAL small non-zero tolerance used to check if
  !                          target point is in domain and for point coincidence.
  !       DCIN    Real   I   OPTIONAL distance outside of source grid in
  !                          units of cell width to treat target point as
  !                          inside the source grid.  Default is 0.
  !       WDTH    Real   I   OPTIONAL width for gaussian filter in units of
  !                          source grid cell width.  Required if RTYP='filter'.
  !                          Actual width used is MIN(WDTH,1.5).
  !       MASK    L.A.   I   OPTIONAL logical mask for source grid.
  !                          (T = invalid, F = valid)
  !                          DIMENSION must be same as GSU coordinate arrays.
  !       NMSK    Int.   I   OPTIONAL maximum number of masked points for
  !                          treating an enclosing source grid cell as partially
  !                          masked. Must be >= 0 and < 4.  Default is 2.
  !       DEBUG   Log.   I   OPTIONAL logical flag to turn on debug mode.
  !                          Default is FALSE.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !     - Check on previous initialization of grid search utility object.
  !     - Check on appropriate input of optional arguments.
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !     -----------------------------------------------------------------
  !      1.  Test input
  !      2.  Initialize search
  !      3.  Find enclosing cell and compute relative index space location
  !      4.  Compute source grid points and remapping coefficients
  !      5.  Adjust for partially masked cell and enforce normalization
  !      6.  Load into return arrays and release work arrays
  !     -----------------------------------------------------------------
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3grmc_r4( GSU, XTIN, YTIN, RTYP, NS, IS, JS, CS, EPS, &
       DCIN, WDTH, MASK, NMSK, DEBUG ) RESULT(INGRID)
    !     Single precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(4), INTENT(IN)     :: xtin
    REAL(4), INTENT(IN)     :: ytin
    CHARACTER(6), INTENT(IN):: rtyp
    INTEGER, INTENT(OUT)    :: ns
    INTEGER, INTENT(INOUT), POINTER :: is(:)
    INTEGER, INTENT(INOUT), POINTER :: js(:)
    REAL(4), INTENT(INOUT), POINTER :: cs(:)
    REAL(4), INTENT(IN)   , OPTIONAL :: eps
    REAL(4), INTENT(IN)   , OPTIONAL :: dcin
    REAL(4), INTENT(IN)   , OPTIONAL :: wdth
    LOGICAL, INTENT(IN)   , OPTIONAL :: mask(:,:)
    INTEGER, INTENT(IN)   , OPTIONAL :: nmsk
    LOGICAL, INTENT(IN)   , OPTIONAL :: debug
 
    !     Local parameters
    REAL(8) :: leps, ldcin, lwdth=zero
    REAL(8) :: xt, yt
    REAL(8), POINTER :: cs8(:) => null()
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GRMC_R4')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Test input
    !
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
    !
    SELECT CASE (rtyp)
    CASE ('nearpt')
    CASE ('bilinr')
    CASE ('bicubc')
    CASE ('filter')
      IF ( .NOT.PRESENT(wdth) ) THEN
        WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', &
             'WDTH parameter is required with RTYP = filter'
        CALL extcde (1)
      ELSE
        lwdth = wdth
      END IF
    CASE DEFAULT
      WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', &
           'RTYP = '//rtyp//' not supported'
      CALL extcde (1)
    END SELECT
    !
    IF ( PRESENT(eps) ) THEN
      IF ( eps .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', &
             'EPS parameter must be >= 0'
        CALL extcde (1)
      END IF
      leps = eps
    ELSE
      leps = eps_default
    END IF
    !
    IF ( PRESENT(dcin) ) THEN
      IF ( dcin .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GRMC_R4 ERROR -- ', &
             'DCIN parameter must be >= 0'
        CALL extcde (1)
      END IF
      ldcin = dcin
    ELSE
      ldcin = zero
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Call into double precision method
    !
    xt = xtin;  yt = ytin;
    ingrid = w3grmc( gsu, xt, yt, rtyp, ns, is, js, cs8, &
         eps=leps, dcin=ldcin, wdth=lwdth, &
         mask=mask, nmsk=nmsk, debug=debug )
    IF ( ns.GT.0 ) THEN
      ALLOCATE( cs(ns) )
      cs(:) = cs8(:)
      DEALLOCATE( cs8 )
    END IF
 
  END FUNCTION w3grmc_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3grmc_r8( GSU, XTIN, YTIN, RTYP, NS, IS, JS, CS, EPS, &
       DCIN, WDTH, MASK, NMSK, DEBUG ) RESULT(INGRID)
    !     Double precision interface
    LOGICAL                 :: ingrid
    TYPE(t_gsu), INTENT(IN) :: gsu
    REAL(8), INTENT(IN)     :: xtin
    REAL(8), INTENT(IN)     :: ytin
    CHARACTER(6), INTENT(IN):: rtyp
    INTEGER, INTENT(OUT)    :: ns
    INTEGER, INTENT(INOUT), POINTER :: is(:)
    INTEGER, INTENT(INOUT), POINTER :: js(:)
    REAL(8), INTENT(INOUT), POINTER :: cs(:)
    REAL(8), INTENT(IN)   , OPTIONAL :: eps
    REAL(8), INTENT(IN)   , OPTIONAL :: dcin
    REAL(8), INTENT(IN)   , OPTIONAL :: wdth
    LOGICAL, INTENT(IN)   , OPTIONAL :: mask(:,:)
    INTEGER, INTENT(IN)   , OPTIONAL :: nmsk
    LOGICAL, INTENT(IN)   , OPTIONAL :: debug
 
    !     Local parameters
    LOGICAL, PARAMETER :: lcmp = .true.
    INTEGER, PARAMETER :: nmsk_default = 2
    REAL(8), PARAMETER :: big = 1d16
    REAL(8) :: leps, lwdth=zero
    LOGICAL :: ldbg, fncl, pole, doblc, lmsk
    INTEGER :: i, ii, jj, k, kk, mcs, mcsmax
    INTEGER :: ic(4), jc(4)
    REAL(8) :: xt, yt, xc(4), yc(4)
    REAL(8) :: xtc, ytc, xsc(4), ysc(4)
    REAL(8) :: ldcin, ixr, jxr, dd, lon0, lat0, dmin
    REAL(8) :: ix, jx, czs
    INTEGER :: nz
    LOGICAL, POINTER :: lz(:)=>null()
    INTEGER, POINTER :: iz(:)=>null(), jz(:)=>null()
    REAL(8), POINTER :: cz(:)=>null()
    LOGICAL :: ijg, llg, lclo
    INTEGER :: iclo, gkind
    INTEGER :: lbx, lby, ubx, uby, nx, ny
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GRMC_R8')
#endif
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Test input
    !
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
    !
    SELECT CASE (rtyp)
    CASE ('nearpt')
    CASE ('bilinr')
    CASE ('bicubc')
    CASE ('filter')
      IF ( .NOT.PRESENT(wdth) ) THEN
        WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', &
             'WDTH parameter is required with RTYP = filter'
        CALL extcde (1)
      ELSE
        lwdth = wdth
      END IF
    CASE DEFAULT
      WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', &
           'RTYP = '//rtyp//' not supported'
      CALL extcde (1)
    END SELECT
    !
    IF ( PRESENT(eps) ) THEN
      IF ( eps .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', &
             'EPS parameter must be >= 0'
        CALL extcde (1)
      END IF
      leps = eps
    ELSE
      leps = eps_default
    END IF
    !
    IF ( PRESENT(dcin) ) THEN
      IF ( dcin .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', &
             'DCIN parameter must be >= 0'
        CALL extcde (1)
      END IF
      ldcin = dcin
    ELSE
      ldcin = zero
    END IF
    !
    IF ( PRESENT(nmsk) ) THEN
      IF ( nmsk .LT. zero .OR. nmsk .GE. 4 ) THEN
        WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', &
             'NMSK parameter must be >= 0 and < 4'
        CALL extcde (1)
      END IF
      mcsmax = nmsk
    ELSE
      mcsmax = nmsk_default
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Initialize search
    !
    IF ( PRESENT(debug) ) THEN
      ldbg = debug
    ELSE
      ldbg = .false.
    END IF
    !
    !  Local pointers to grid search utility object data
    ijg = gsu%PTR%IJG
    llg = gsu%PTR%LLG
    iclo = gsu%PTR%ICLO
    lclo = gsu%PTR%LCLO
    gkind = gsu%PTR%GKIND
    lbx = gsu%PTR%LBX;  lby = gsu%PTR%LBY;
    ubx = gsu%PTR%UBX;  uby = gsu%PTR%UBY;
    nx = gsu%PTR%NX;  ny = gsu%PTR%NY;
    !
    IF ( PRESENT(mask) ) THEN
      IF ( ijg ) THEN
        IF ( .NOT.(ubound(mask,1).EQ.nx.AND. &
             ubound(mask,2).EQ.ny) ) THEN
          WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', &
               'MASK array size does not agree with GSU index bounds'
          CALL extcde (1)
        END IF
      ELSE
        IF ( .NOT.(ubound(mask,2).EQ.nx.AND. &
             ubound(mask,1).EQ.ny) ) THEN
          WRITE(0,'(/2A/)') 'W3GRMC_R8 ERROR -- ', &
               'MASK array size does not agree with GSU index bounds'
          CALL extcde (1)
        END IF
      END IF
    END IF
    !
    ns = 0
    IF ( ASSOCIATED(is) ) THEN
      DEALLOCATE( is )
      NULLIFY( is )
    END IF
    IF ( ASSOCIATED(js) ) THEN
      DEALLOCATE( js )
      NULLIFY( js )
    END IF
    IF ( ASSOCIATED(cs) ) THEN
      DEALLOCATE( cs )
      NULLIFY( cs )
    END IF
    !
    xt = xtin;  yt = ytin;
    IF ( ldbg ) WRITE(*,'(/A,2E24.16)') 'W3GRMC_R8 - TARGET POINT:',xt,yt
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Find enclosing cell and compute relative index space location
    !
    fncl = ldcin .GT. zero
    ingrid = w3gfcl(gsu,xt,yt,ic,jc,xc,yc,pole=pole,eps=leps,fncl=fncl,debug=ldbg)
    IF ( .NOT.ingrid .AND. .NOT.fncl ) RETURN
    !
    !-----Compute cell relative index space location
    lon0 = sum(xc)/four; lat0 = sum(yc)/four;
    IF ( d90-abs(lat0).GT.near_pole ) THEN
      !---------non-pole cell: compute relative location using (lon,lat)
      CALL getpqr(xt,yt,xc,yc,ixr,jxr,eps=leps,debug=ldbg)
    ELSE
      !---------pole cell: compute relative location using stereographic projection
      CALL w3splx(lon0,lat0,zero,xt,yt,xtc,ytc)
      DO i=1,4
        CALL w3splx(lon0,lat0,zero,xc(i),yc(i),xsc(i),ysc(i))
      END DO
      CALL getpqr(xtc,ytc,xsc,ysc,ixr,jxr,eps=leps,debug=ldbg)
    ENDIF
    IF ( ldbg ) &
         WRITE(*,'(A,2L2,2E24.16)') 'W3GRMC_R8 - RELATIVE:',ingrid,fncl,ixr,jxr
    !
    !-----Set in grid if point is within DCIN cell width distance of closest cell
    IF ( .NOT.ingrid .AND. fncl ) THEN
      dd = half + ldcin
      ingrid = abs(ixr-half).LE.dd .AND. abs(jxr-half).LE.dd
    END IF
    IF ( .NOT.ingrid ) RETURN
    !
    !-----Compute absolute index space location
    ix = ic(1) + ixr;  jx = jc(1) + jxr;
    !
    !-----Determine if target point is coincident with an
    !     unmasked source grid cell point (KK)
    kk_loop: DO kk=1,4
      IF ( abs(ic(kk)-ix).LE.leps .AND. &
           abs(jc(kk)-jx).LE.leps ) THEN
        IF ( PRESENT(mask) ) THEN
          IF ( ijg ) THEN
            IF ( .NOT.mask(ic(kk)-lbx+1,jc(kk)-lby+1) ) EXIT kk_loop
          ELSE
            IF ( .NOT.mask(jc(kk)-lby+1,ic(kk)-lbx+1) ) EXIT kk_loop
          END IF
        ELSE
          EXIT kk_loop
        END IF
      END IF
    END DO kk_loop
    !
    !-----Count number of masked points in source cell
    mcs = 0
    IF ( PRESENT(mask) ) THEN
      DO k=1,4
        IF ( ijg ) THEN
          IF ( mask(ic(k)-lbx+1,jc(k)-lby+1) ) mcs = mcs+1
        ELSE
          IF ( mask(jc(k)-lby+1,ic(k)-lbx+1) ) mcs = mcs+1
        END IF
      END DO
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 4.  Compute source grid points and remapping coefficients
    !
    SELECT CASE (rtyp)
    CASE ('nearpt')
      ! *** nearest point ***
      dmin = big
      DO k=1,4
        dd = (ix - ic(k))**2 + (jx - jc(k))**2
        IF ( dd .LT. dmin ) THEN
          dmin = dd;  ii = ic(k);  jj = jc(k);
        END IF
      END DO
      nz = 1
      IF ( PRESENT(mask) ) THEN
        IF ( ijg ) THEN
          IF ( mask(ii-lbx+1,jj-lby+1) ) nz = 0
        ELSE
          IF ( mask(jj-lby+1,ii-lbx+1) ) nz = 0
        END IF
      END IF
      IF ( nz.EQ.1 ) THEN
        ! nearest point is unmasked
        ! set number of points to one and coefficient to one
        ALLOCATE( lz(nz), iz(nz), jz(nz), cz(nz) )
        lz(nz) = .true.
        iz(nz) = ii
        jz(nz) = jj
        cz(nz) = one
      ELSE
        ! nearest point is masked
        ! set number of points to zero and return
        ns = 0
        RETURN
      END IF
    CASE ('bilinr')
      ! *** bilinear interpolation ***
      IF ( kk.LE.4 ) THEN
        ! coincident with unmasked point kk
        ! set number of points to one and coefficient to one
        nz = 1
        ALLOCATE( lz(nz), iz(nz), jz(nz), cz(nz) )
        lz(nz) = .true.
        iz(nz) = ic(kk)
        jz(nz) = jc(kk)
        cz(nz) = one
      ELSE
        ! no coincident points
        IF ( mcs.LE.mcsmax ) THEN
          ! unmasked or partially masked cell
          ! set bilinear interpolation
          CALL getblc( gsu, ic(1), jc(1), ixr, jxr, &
               lcmp, nz, lz, iz, jz, cz )
        ELSE
          ! fully masked cell
          ! set number of points to zero and return
          ns = 0
          RETURN
        END IF
      END IF
    CASE ('bicubc')
      ! *** bicubic interpolation ***
      IF ( kk.LE.4 ) THEN
        ! coincident with unmasked point kk
        ! set number of points to one and coefficient to one
        nz = 1
        ALLOCATE( lz(nz), iz(nz), jz(nz), cz(nz) )
        lz(nz) = .true.
        iz(nz) = ic(kk)
        jz(nz) = jc(kk)
        cz(nz) = one
      ELSE
        ! no coincident points
        IF ( mcs.EQ.0 ) THEN
          ! unmasked cell
          ! get bicubic interpolation
          CALL getbcc( gsu, ic(1), jc(1), ixr, jxr, &
               lcmp, nz, lz, iz, jz, cz )
          ! check for masked points in bicubic stencil
          doblc = .false.
          IF ( PRESENT(mask) ) THEN
            check: DO k=1,nz
              IF ( lz(k) ) THEN
                IF ( ijg ) THEN
                  lmsk = mask(iz(k)-lbx+1,jz(k)-lby+1)
                ELSE
                  lmsk = mask(jz(k)-lby+1,iz(k)-lbx+1)
                END IF
                IF ( lmsk ) THEN
                  doblc = .true.
                  EXIT check
                END IF
              END IF
            END DO check
          END IF
          IF ( doblc ) THEN
            ! masked points in bicubic stencil
            ! set bilinear interpolation
            CALL getblc( gsu, ic(1), jc(1), ixr, jxr, &
                 lcmp, nz, lz, iz, jz, cz )
          END IF
        ELSE IF ( mcs.LE.mcsmax ) THEN
          ! partially masked cell
          ! set bilinear interpolation
          CALL getblc( gsu, ic(1), jc(1), ixr, jxr, &
               lcmp, nz, lz, iz, jz, cz )
        ELSE
          ! fully masked cell
          ! set number of points to zero and return
          ns = 0
          RETURN
        END IF
      END IF
    case ('filter')
      ! *** gaussian filter ***
      IF ( mcs.LE.mcsmax ) THEN
        ! unmasked or partially masked cell
        ! get gaussian filter
        CALL getgfc( gsu, ic(1), jc(1), ixr, jxr, &
             lwdth, lcmp, nz, lz, iz, jz, cz )
      ELSE
        ! fully masked cell
        ! set number of points to zero and return
        ns = 0
        RETURN
      END IF
    END SELECT
    !
    ! -------------------------------------------------------------------- /
    ! 5.  Adjust for partially masked cell and enforce normalization
    !
    IF ( nz .GT. 1 ) THEN
      czs = zero
      DO k=1,nz
        IF ( lz(k) ) THEN
          IF ( PRESENT(mask) ) THEN
            IF ( ijg ) THEN
              lmsk = mask(iz(k)-lbx+1,jz(k)-lby+1)
            ELSE
              lmsk = mask(jz(k)-lby+1,iz(k)-lbx+1)
            END IF
            IF ( lmsk ) THEN
              lz(k) = .false.
              cz(k) = zero
            ELSE
              czs = czs + cz(k)
            END IF
          ELSE
            czs = czs + cz(k)
          END IF
        END IF
      END DO
      IF ( czs .GT. zero ) THEN
        DO k=1,nz
          IF ( lz(k) ) cz(k) = cz(k)/czs
        ENDDO
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 6.  Load into return arrays and release work arrays
    !
    ns = 0
    DO k=1,nz
      IF ( lz(k) ) ns = ns + 1
    END DO
    IF ( ns.GT.0 ) THEN
      ALLOCATE( is(ns), js(ns), cs(ns) )
      ns = 0
      DO k=1,nz
        IF ( lz(k) ) THEN
          ns = ns + 1
          is(ns) = iz(k)
          js(ns) = jz(k)
          cs(ns) = cz(k)
        END IF
      END DO
    END IF
 
    DEALLOCATE( lz, iz, jz, cz )
 
  END FUNCTION w3grmc_r8
  !/
  !/ End of W3GRMC ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3CKCL( LLG, XT, YT, NS, XS, YS, POLE, EPS, DEBUG ) &
  !/    RESULT(INCELL)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Check if point lies within grid cell.
  !
  !  2. Method :
  !
  !     Calculates cross products for vertex to vertex (i.e. cell side)
  !     vs vertex to target. If all cross products have the same sign,
  !     the point is considered to be within the cell. Since they can
  !     be "all positive" *or* "all negative", there are no pre-conditions
  !     that the order of specification of the vertices be clockwise vs.
  !     counter-clockwise geographically.  The logical variable POLE is
  !     set to true if the grid cell includes a pole.
  !
  !  3. Parameters :
  !
  !     Return parameter
  !     ----------------------------------------------------------------
  !       INCELL  Log.   O   Logical flag indicating point is in the cell
  !     ----------------------------------------------------------------
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       LLG     Log.   I   Logical flag indicating the coordinate system:
  !                          T = spherical lat/lon (degrees) and F = Cartesian.
  !       XT      Real   I   X-coordinate of target point.
  !       YT      Real   I   Y-coordinate of target point.
  !       XS      R.A.   I   X-coordinates of source cell vertices.
  !       YS      R.A.   I   Y-coordinates of source cell vertices.
  !       POLE    Log.   O   OPTIONAL output logical flag to indicate
  !                          the source cell contains a pole.
  !       EPS     Real   I   OPTIONAL small non-zero tolerance used to check
  !                          for point coincidence.
  !       DEBUG   Log.   I   OPTIONAL logical flag to turn on debug mode.
  !                          Default is FALSE.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !     - For LL grids, this method assumes that the longitudes of point
  !       and grid cell vertices lie in the same range (i.e., both in [0:360]
  !       or [-180:180]).  If the longitudes are not in the same range, then
  !       this method may result in a false positive.  The burden is upon the
  !       caller to ensure that the longitude range of the point is the same
  !       as that of the grid cell vertices.
  !     - If enclosing cell includes a branch cut, then the coordinates of
  !       of the cell vertices AND the target point will be adjusted so
  !       that the branch cut is shifted 180 degrees.
  !     - If the enclosing cell includes a pole, then the cross-product check
  !       is performed using coordinates in a stereographic projection.
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3ckcl_r4( LLG, XT, YT, NS, XS, YS, POLE, EPS, DEBUG ) &
       result(incell)
    !     Single precision interface
    LOGICAL                :: incell
    LOGICAL, INTENT(IN)    :: llg
    REAL(4), INTENT(INOUT) :: xt, yt
    INTEGER, INTENT(IN)    :: ns
    REAL(4), INTENT(INOUT) :: xs(ns), ys(ns)
    LOGICAL, INTENT(OUT)   :: pole
    REAL(4), INTENT(IN), OPTIONAL :: eps
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    REAL(8) :: xt8, yt8, xs8(ns), ys8(ns), eps8
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3CKCL_R4')
#endif
    !
    !-----set inputs
    xt8 = xt;  xs8 = xs;
    yt8 = yt;  ys8 = ys;
    IF ( PRESENT(eps) ) THEN
      eps8 = eps
    ELSE
      eps8 = eps_default
    END IF
    !
    !-----call double precision method
    incell = w3ckcl( llg, xt8, yt8, ns, xs8, ys8, pole, &
         eps=eps8, debug=debug )
    !
    !-----return branch cut shifted coordinates
    xt = xt8;  xs = xs8;
 
  END FUNCTION w3ckcl_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3ckcl_r8( LLG, XT, YT, NS, XS, YS, POLE, EPS, DEBUG ) &
       result(incell)
    !     Double precision interface
    LOGICAL                :: incell
    LOGICAL, INTENT(IN)    :: llg
    REAL(8), INTENT(INOUT) :: xt, yt
    INTEGER, INTENT(IN)    :: ns
    REAL(8), INTENT(INOUT) :: xs(ns), ys(ns)
    LOGICAL, INTENT(OUT)   :: pole
    REAL(8), INTENT(IN), OPTIONAL :: eps
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    REAL(8) :: leps
    LOGICAL :: ldbg, lsbc, bcut
    INTEGER :: i, j, k, n
    REAL(8) :: xxt, yyt, xxs(ns), yys(ns)
    REAL(8) :: xct, yct, xcs(ns), ycs(ns)
    REAL(8) :: v1x, v1y, v2x, v2y, s90
    REAL(8) :: cross
    REAL(8) :: sign1
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3CKCL_R8')
#endif
 
    incell = .true.
    !
    !-----must have >= 3 points to be a cell
    IF ( ns .LT. 3 ) THEN
      incell = .false.
      RETURN
    END IF
    !
    IF ( PRESENT(eps) ) THEN
      IF ( eps .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'W3CKCL_R8 ERROR -- ', &
             'EPS parameter must be >= 0'
        CALL extcde (1)
      END IF
      leps = eps
    ELSE
      leps = eps_default
    END IF
    IF ( PRESENT(debug) ) THEN
      ldbg = debug
    ELSE
      ldbg = .false.
    END IF
    !
    !-----set local copies
    xxt = xt;  xxs = xs;
    yyt = yt;  yys = ys;
    !
    !-----check if cell includes a pole or branch cut
    IF ( llg ) THEN
      n = 0
      !---------count longitudinal branch cut crossings
      DO i=1,ns
        j = mod(i,ns) + 1
        IF ( abs(xxs(j)-xxs(i)) .GT. d180 ) n = n + 1
      END DO
      !---------multiple longitudinal branch cut crossing => cell includes branch cut
      bcut = n.GT.1
      !---------single longitudinal branch cut crossing
      !         or single vertex at 90 degrees => cell includes pole
      pole = n.EQ.1 .OR. count(abs(d90-abs(yys)).LE.leps).EQ.1
    ELSE
      pole = .false.
      bcut = .false.
    END IF
    !
    !-----shift branch cut if necessary
    IF ( bcut ) THEN
      IF ( minval(xxs) .GE. zero ) THEN
        WHERE ( xxs .GT. d180 ) xxs = xxs - d360
        IF ( xxt .GT. d180 ) xxt = xxt - d360
      ELSE
        WHERE ( xxs .LT. zero ) xxs = xxs + d360
        IF ( xxt .LT. zero ) xxt = xxt + d360
      END IF
      IF ( ldbg ) THEN
        WRITE(*,'(A)') 'W3CKCL_R8 - CELL INCLUDES A BRANCH CUT'
        WRITE(*,'(A,2E24.16,4(/A,1I1,A,2E24.16))') &
             'W3CKCL_R8 - SHIFT BRANCH CUT:',xxt,yyt, &
             ('          CORNER(',k,'):',xxs(k),yys(k),k=1,4)
      END IF
    END IF
    !
    !-----check for coincidence with a cell vertex
    DO i=1,ns
      !---------if target point is coincident a cell vertex, then
      !         flag as in cell and return
      IF ( abs(xxt-xxs(i)).LE.leps .AND. abs(yyt-yys(i)).LE.leps ) THEN
        IF ( ldbg ) &
             WRITE(*,'(A,I1,A,2E24.16)') &
             'W3CKCL_R8 - COINCIDENT WITH CORNER(',i,'): ', &
             abs(xxt-xxs(i)),abs(yyt-yys(i))
        !-------------return branch cut shifted coordinates
        IF ( bcut ) THEN
          xt = xxt;  xs = xxs;
        END IF
        incell = .true.
        RETURN
      END IF
    END DO
    !
    !-----handle cell that includes a pole
    IF ( pole ) THEN
      !---------perform cross-product check for each subcell
      IF ( ldbg ) &
           WRITE(*,'(A)') 'W3CKCL_R8 - CELL INCLUDES A POLE'
      s90 = d90; IF ( maxval(ys).LT.zero ) s90 = -d90;
      subcell_loop: DO i=1,ns
        lsbc = .true.
        j = mod(i,ns) + 1
        sign1 = 0.0
        DO k=1,4
          SELECT CASE (k)
          CASE (1)
            !---------------------vector from (xi,yi) to (xj,yj)
            v1x = xxs(j) - xxs(i)
            v1y = yys(j) - yys(i)
            !---------------------vector from (xi,yi) to (xt,yt)
            v2x = xxt    - xxs(i)
            v2y = yyt    - yys(i)
          CASE (2)
            !---------------------vector from (xj,yj) to (xj,90)
            v1x = xxs(j) - xxs(j)
            v1y = s90    - yys(j)
            !---------------------vector from (xj,yj) to (xt,yt)
            v2x = xxt    - xxs(j)
            v2y = yyt    - yys(j)
          CASE (3)
            !---------------------vector from (xj,90) to (xi,90)
            v1x = xxs(i) - xxs(j)
            v1y = s90    - s90
            !---------------------vector from (xj,90) to (xt,yt)
            v2x = xxt    - xxs(j)
            v2y = yyt    - s90
          CASE (4)
            !---------------------vector from (xi,90) to (xi,yi)
            v1x = xxs(i) - xxs(i)
            v1y = yys(i) - s90
            !---------------------vector from (xi,90) to (xt,yt)
            v2x = xxt    - xxs(i)
            v2y = yyt    - s90
          END SELECT
          !-----------------check for longitudinal branch cut crossing
          IF ( abs(v1x) .GT. d180 ) THEN
            v1x = v1x - sign(d360,v1x)
          END IF
          IF ( abs(v2x) .GT. d180 ) THEN
            v2x = v2x - sign(d360,v2x)
          END IF
          !-----------------cross product
          cross = v1x*v2y - v1y*v2x
          !-----------------handle point that lies exacly on side or zero length side
          IF ( abs(cross) .LT. leps ) cross = zero
          IF ( ldbg ) &
               WRITE(*,'(A,3(I1,A),5E24.16)') 'W3CKCL_R8 - CROSS(', &
               i,',',j,',',k,'):',v1x,v1y,v2x,v2y,cross
          !-----------------if sign of cross product is not "unanimous" among the
          !                 subcell sides, then target is outside the subcell
          IF ( abs(sign1) .LE. leps ) THEN
            IF (abs(cross) .GT. leps) sign1 = sign(one,cross)
          ELSE
            ! If point lies along a border, the cross product
            ! is zero and its sign is not well defined
            IF ( abs(cross) .GT. leps ) THEN
              IF ( sign(one,cross) .NE. sign1 ) THEN
                lsbc = .false.
                cycle subcell_loop
              END IF
            END IF
          END IF
        END DO !K
        IF ( lsbc ) RETURN
      END DO subcell_loop
      incell = .false.
      RETURN
    ELSE
      !---------use input coordinates
      xct = xxt;  yct = yyt;
      xcs = xxs;  ycs = yys;
    END IF !POLE
    !
    !-----perform cross-product cell check
    sign1 = 0.0
    DO i=1,ns
      j = mod(i,ns) + 1
      !---------vector from (xi,yi) to (xj,yj)
      v1x = xcs(j) - xcs(i)
      v1y = ycs(j) - ycs(i)
      !---------vector from (xi,yi) to (xt,yt)
      v2x = xct    - xcs(i)
      v2y = yct    - ycs(i)
      !---------cross product
      cross = v1x*v2y - v1y*v2x
      !---------handle point that lies exacly on side or zero length side
      IF ( abs(cross) .LT. leps ) cross = zero
      IF ( ldbg ) &
           WRITE(*,'(A,2(I1,A),5E24.16)') 'W3CKCL_R8 - CROSS(', &
           i,',',j,'):',v1x,v1y,v2x,v2y,cross
      !---------if sign of cross product is not "unanimous" among the cell sides,
      !         then target is outside the cell
      IF ( abs(sign1) .LE. leps ) THEN
        IF (abs(cross) .GT. leps) sign1 = sign(one,cross)
      ELSE
        ! If point lies along a border, the cross product
        ! is zero and its sign is not well defined
        IF ( abs(cross) .GT. leps ) THEN
          IF ( sign(one,cross) .NE. sign1 ) THEN
            incell = .false.
            RETURN
          END IF
        END IF
      END IF
    END DO
    !
    !-----return branch cut shifted coordinates
    IF ( bcut ) THEN
      xt = xxt;  xs = xxs;
    END IF
 
  END FUNCTION w3ckcl_r8
  !/
  !/ End of W3CKCL ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3CGDM( IJG, LLG, ICLO, PTILED, QTILED, &
  !/                       PRANGE, QRANGE, LBI, UBI, LBO, UBO, X, Y, &
  !/                       MASK, NFD, SPHERE, RADIUS, DX, DY, &
  !/                       GPPC, GQQC, GPQC, GSQR, &
  !/                       HPFC, HQFC, APPC, AQQC, APQC, &
  !/                       DXDP, DYDP, DXDQ, DYDQ, &
  !/                       DPDX, DPDY, DQDX, DQDY, &
  !/                       COSA, COSC, SINC, ANGL, RC )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute curvilinear grid derivatives and metric.
  !
  !  2. Method :
  !
  !     Curvilinear grid is defined by the input coordinates as a function
  !     of the (P,Q) index coordinates:
  !
  !         x = x(p,q),  y = y(p,q),  dp = dq = 1.
  !
  !     When using spherical coordinates (llg=T) x = longitude and
  !     y = latitude in degrees.  The optional sphere input (default is true)
  !     controls whether or not the spherical coordinate metric is applied.
  !     If sphere is true, then the spherical coordinate metric is applied
  !     to the coordinate derivatives with respect to p & q.  In other words,
  !
  !         dx/dp <= d2r*radius*cos(y)*(dx/dp),
  !         dx/dq <= d2r*radius*cos(y)*(dx/dq),
  !         dy/dp <= d2r*radius*(dy/dp), and
  !         dy/dq <= d2r*radius*(dy/dq).
  !
  !     The default radius is Rearth.
  !
  !     The covariant metric tensor components are
  !
  !         g_pp = (dx/dp)*(dx/dp) + (dy/dp)*(dy/dp),
  !         g_qq = (dx/dq)*(dx/dq) + (dy/dq)*(dy/dq),
  !         g_pq = (dx/dp)*(dx/dq) + (dy/dp)*(dy/dq).
  !
  !     The contravariant (associated) metric tensor components are
  !
  !         g^pp = (dp/dx)*(dp/dx) + (dp/dy)*(dp/dy),
  !         g^qq = (dq/dx)*(dq/dx) + (dq/dy)*(dq/dy),
  !         g^pq = (dp/dx)*(dq/dx) + (dp/dy)*(dq/dy).
  !
  !     The curvilinear scale factors are h_p = sqrt(g_pp) and h_q = sqrt(g_qq).
  !     The square root of determinant of metric tensor is
  !
  !         sqrt(|g|) = sqrt( g_pp*g_qq - g_pq^2 )
  !                   = (dx/dp)(dy/dq) - (dx/dq)(dy/dp)
  !                   = h_p*h_q*sqrt(sin(alpha))
  !                   = cell area.
  !
  !     The curvilinear derivatives are computed as
  !
  !         dp/dx =  (1/sqrt(g))*(dy/dq),
  !         dp/dy = -(1/sqrt(g))*(dx/dq),
  !         dq/dx = -(1/sqrt(g))*(dy/dp),
  !         dq/dy =  (1/sqrt(g))*(dx/dp).
  !
  !     Orthogonality of grid can be checked by computing angle between the
  !     curvilinear coordinate unit vectors:
  !
  !         cos(alpha) = g_pq/(h_p*h_q) = uvec_p \dot uvec_q,
  !
  !     where
  !
  !         uvec_p = (1/h_p)*(dx/dp)*uvec_x + (1/h_p)*(dy/dp)*uvec_y,
  !         uvec_q = (1/h_q)*(dx/dq)*uvec_x + (1/h_q)*(dy/dq)*uvec_y.
  !
  !     The local cell rotation angle is (assuming orthogonal):
  !
  !         cos(theta) = (1/h_p)*dx/dp,
  !         sin(theta) = (1/h_q)*dy/dp,
  !         theta      = atan2((1/h_q)*dy/dp,(1/h_p)*dx/dp).
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       IJG     Log.   I   Logical flag indicating ordering of input
  !                          coord. arrays: T = (NP,NQ) and F = (NP,NQ)
  !       LLG     Log.   I   Spherical coordinate (lon,lat) flag
  !       ICLO    Int.   I   Parameter indicating type of index space closure
  !       PTILED  Log.   I   Logical flag indicating that input arrays are tiled
  !                          in P-axis with halos of width >= NFD/2
  !       QTILED  Log.   I   Logical flag indicating that input arrays are tiled
  !                          in Q-axis with halos of width >= NFD/2
  !       PRANGE  I.A.   I   Range of P index coordinate: P in [PRANGE(1),PRANGE(2)]
  !       QRANGE  I.A.   I   Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)]
  !       LBI     I.A.   I   Lower-bound of  input arrays, DIMENSION(2)
  !       UBI     I.A.   I   Upper-bound of  input arrays, DIMENSION(2)
  !       LBO     I.A.   I   Lower-bound of output arrays, DIMENSION(2)
  !       UBO     I.A.   I   Upper-bound of output arrays, DIMENSION(2)
  !       X       R.A.   I   Gridded X-coordinates, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       Y       R.A.   I   Gridded Y-coordinates, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       MASK    L.A.   I   OPTIONAL logical mask (T = invalid, F = valid)
  !                          DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       NFD     Int.   I   OPTIONAL finite-difference order (even), Default is NFD_DEFAULT.
  !       SPHERE  Log.   I   OPTIONAL apply spherical coord metric if LLG, Default is T
  !       RADIUS  Real   I   OPTIONAL radius for sphere.  Default is REARTH
  !       DX      Real   I   OPTIONAL constant spacing in x-direction
  !       DY      Real   I   OPTIONAL constant spacing in y-direction
  !       GPPC    R.A.   O   OPTIONAL g_pp,       DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       GQQC    R.A.   O   OPTIONAL g_qq,       DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       GPQC    R.A.   O   OPTIONAL g_pq,       DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       GSQR    R.A.   O   OPTIONAL sqrt(|g|),  DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       HPFC    R.A.   O   OPTIONAL h_p,        DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       HQFC    R.A.   O   OPTIONAL h_q,        DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       APPC    R.A.   O   OPTIONAL g^pp,       DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       AQQC    R.A.   O   OPTIONAL g^qq,       DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       APQC    R.A.   O   OPTIONAL g^pq,       DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       DXDP    R.A.   O   OPTIONAL dx/dp,      DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       DYDP    R.A.   O   OPTIONAL dy/dp,      DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       DXDQ    R.A.   O   OPTIONAL dx/dq,      DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       DYDQ    R.A.   O   OPTIONAL dy/dq,      DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       DPDX    R.A.   O   OPTIONAL dp/dx,      DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       DPDY    R.A.   O   OPTIONAL dp/dy,      DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       DQDX    R.A.   O   OPTIONAL dq/dx,      DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       DQDY    R.A.   O   OPTIONAL dq/dy,      DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       COSA    R.A.   O   OPTIONAL cos(alpha), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       COSC    R.A.   O   OPTIONAL cos(theta), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       SINC    R.A.   O   OPTIONAL sin(theta), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       ANGL    R.A.   O   OPTIONAL theta,      DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       RC      Int.   O   OPTIONAL return code (!= 0 if error occurs)
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !     - The derivatives and metric will be computed using the constant
  !       spacing DX and/or DY if they are specified.  DX & DY are assumed
  !       to be in degrees when LLG = T.
  !     - The grid derivatives (dx/dp, dy/dp, dx/dq, dy/dq) are computed
  !       using a finite difference method.
  !     - When LLG = T, the finite differences are done in a polar
  !       stereographic projection.
  !     - If RC is not provided and an error occurs, then the routine will
  !       report error to stderr and attempt to abort the calling program.
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3cgdm_r4( IJG, LLG, ICLO, PTILED, QTILED, &
       PRANGE, QRANGE, LBI, UBI, LBO, UBO, X, Y, &
       MASK, NFD, SPHERE, RADIUS, DX, DY, &
       GPPC, GQQC, GPQC, GSQR, &
       HPFC, HQFC, APPC, AQQC, APQC, &
       DXDP, DYDP, DXDQ, DYDQ, &
       DPDX, DPDY, DQDX, DQDY, &
       COSA, COSC, SINC, ANGL, RC )
    !     Single precision interface
    LOGICAL, INTENT(IN)   :: ijg
    LOGICAL, INTENT(IN)   :: llg
    INTEGER, INTENT(IN)   :: iclo
    LOGICAL, INTENT(IN)   :: ptiled, qtiled
    INTEGER, INTENT(IN)   :: prange(2), qrange(2)
    INTEGER, INTENT(IN)   :: lbi(2), ubi(2)
    INTEGER, INTENT(IN)   :: lbo(2), ubo(2)
    REAL(4), INTENT(IN)   :: x(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   :: y(lbi(1):ubi(1),lbi(2):ubi(2))
    LOGICAL, INTENT(IN),  OPTIONAL :: mask(lbi(1):ubi(1),lbi(2):ubi(2))
    INTEGER, INTENT(IN),  OPTIONAL :: nfd
    LOGICAL, INTENT(IN),  OPTIONAL :: sphere
    REAL(4), INTENT(IN),  OPTIONAL :: radius
    REAL(4), INTENT(IN),  OPTIONAL :: dx, dy
    REAL(4), INTENT(OUT), OPTIONAL :: gppc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: gqqc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: gpqc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: gsqr(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: hpfc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: hqfc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: appc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: aqqc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: apqc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: dxdp(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: dydp(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: dxdq(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: dydq(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: dpdx(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: dpdy(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: dqdx(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: dqdy(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: cosa(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: cosc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: sinc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT), OPTIONAL :: angl(lbo(1):ubo(1),lbo(2):ubo(2))
    INTEGER, INTENT(OUT), OPTIONAL :: rc
 
    !     Local parameters
    INTEGER, PARAMETER :: m = 1 ! order of derivative
    REAL(8), PARAMETER :: small = 1d-15
    INTEGER :: istat=0, n, np, nq, i1, i2, p, q
    LOGICAL :: sphr
    REAL(8) :: r, facx, facy
    INTEGER, ALLOCATABLE :: k(:,:,:), k2(:,:,:)
    REAL(8), ALLOCATABLE :: c(:,:,:), c2(:,:,:)
    REAL(8) :: gppcl, gqqcl, gpqcl
    REAL(8) :: gsqrl, hpfcl, hqfcl
    REAL(8) :: appcl, aqqcl, apqcl
    REAL(8) :: dxdpl, dydpl, dxdql, dydql
    REAL(8) :: dpdxl, dpdyl, dqdxl, dqdyl
    REAL(8) :: cosal, sinal, costp, sintp, coscl, sincl, angll
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3CGDM_R4')
#endif
    ! -------------------------------------------------------------------- /
    ! 1.  Check and setup inputs
    !
    IF ( PRESENT(rc) ) rc = 0
 
    IF ( PRESENT(nfd) ) THEN
      n = nfd
    ELSE
      n = nfd_default
    END IF
    IF ( n.LE.0 .OR. mod(n,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', &
           'NFD must be even and greater than zero'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    np = prange(2) - prange(1) + 1
    nq = qrange(2) - qrange(1) + 1
 
    SELECT CASE ( iclo )
    CASE ( iclo_none, iclo_grdi, iclo_grdj, iclo_trdl, iclo_trpl )
      CONTINUE
    CASE DEFAULT
      WRITE(0,'(/1A,1A,1I2/)') 'W3CGDM ERROR -- ', &
           'unsupported ICLO: ',iclo
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END SELECT
 
    IF ( iclo.EQ.iclo_trpl .AND. mod(np,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', &
           'tripole grid closure requires NP even'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    IF ( PRESENT(sphere) ) THEN
      sphr = sphere
    ELSE
      sphr = .true.
    END IF
 
    IF ( PRESENT(radius) ) THEN
      r = radius
    ELSE
      r = rearth
    END IF
    facy = r*d2r
 
    IF ( PRESENT(dx) ) THEN
      IF ( dx.LE.zero ) THEN
        WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DX must be > 0'
        istat = 1
        IF ( PRESENT(rc) ) THEN
          rc = istat
          RETURN
        ELSE
          CALL extcde (istat)
        END IF
      END IF
    END IF
 
    IF ( PRESENT(dy) ) THEN
      IF ( dy.LE.zero ) THEN
        WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DY must be > 0'
        istat = 1
        IF ( PRESENT(rc) ) THEN
          rc = istat
          RETURN
        ELSE
          CALL extcde (istat)
        END IF
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Setup finite difference coefficients
    !
    ALLOCATE ( k(0:n,0:n,1:n), c(0:n,0:n,1:n), stat=istat )
    IF ( istat .NE. 0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', &
           'finite difference coeff allocation failed'
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
    CALL get_fdw3 ( n, m, k, c )
 
    ALLOCATE ( k2(0:2,0:2,1:2), c2(0:2,0:2,1:2), stat=istat )
    IF ( istat .NE. 0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', &
           'finite difference coeff allocation for N=2 failed'
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
    CALL get_fdw3 ( 2, m, k2, c2 )
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Compute optional return quantities
    !
    DO i2 = lbo(2), ubo(2)
      DO i1 = lbo(1), ubo(1)
        IF ( ijg ) THEN
          p = i1
          q = i2
        ELSE
          p = i2
          q = i1
        END IF
        IF ( PRESENT(dx) ) THEN
          dxdpl = dx
          dydpl = zero
        ELSE
          CALL dxydp( n, k, c, ijg, llg, iclo, ptiled, qtiled, &
               prange, qrange, lbi, ubi, p, q, dxdpl, dydpl, &
               mask=mask, x4=x, y4=y, rc=istat )
          IF ( istat .NE. 0 ) THEN
            IF ( PRESENT(rc) ) THEN
              rc = istat
              RETURN
            ELSE
              CALL extcde (istat)
            END IF
          END IF
        END IF
        IF ( PRESENT(dy) ) THEN
          dxdql = zero
          dydql = dy
        ELSE
          CALL dxydq( n, k, c, ijg, llg, iclo, ptiled, qtiled, &
               prange, qrange, lbi, ubi, p, q, dxdql, dydql, &
               mask=mask, x4=x, y4=y, rc=istat )
          IF ( istat .NE. 0 ) THEN
            IF ( PRESENT(rc) ) THEN
              rc = istat
              RETURN
            ELSE
              CALL extcde (istat)
            END IF
          END IF
        END IF
        IF ( llg .AND. sphr ) THEN
          facx = facy*cos(real(y(i1,i2),8)*d2r)
          dxdpl = dxdpl*facx
          dydpl = dydpl*facy
          dxdql = dxdql*facx
          dydql = dydql*facy
        END IF
        gsqrl = dxdpl*dydql - dxdql*dydpl
        IF ( gsqrl .LT. zero .AND. n .GT. 2 ) THEN
          !                 WRITE(0,'(1A,1I0,1A,1I0,1A,1I0,2A)') &
          !                 'W3CGDM WARNING -- NFD = ',N, &
          !                 ' yields GSQRL < 0 at (',P,',',Q,'):', &
          !                 ' computing metrics using NFD = 2'
          IF ( PRESENT(dx) ) THEN
            dxdpl = dx
            dydpl = zero
          ELSE
            CALL dxydp( 2, k2, c2, ijg, llg, iclo, ptiled, qtiled, &
                 prange, qrange, lbi, ubi, p, q, dxdpl, dydpl, &
                 mask=mask, x4=x, y4=y, rc=istat )
            IF ( istat .NE. 0 ) THEN
              IF ( PRESENT(rc) ) THEN
                rc = istat
                RETURN
              ELSE
                CALL extcde (istat)
              END IF
            END IF
          END IF
          IF ( PRESENT(dy) ) THEN
            dxdql = zero
            dydql = dy
          ELSE
            CALL dxydq( 2, k2, c2, ijg, llg, iclo, ptiled, qtiled, &
                 prange, qrange, lbi, ubi, p, q, dxdql, dydql, &
                 mask=mask, x4=x, y4=y, rc=istat )
            IF ( istat .NE. 0 ) THEN
              IF ( PRESENT(rc) ) THEN
                rc = istat
                RETURN
              ELSE
                CALL extcde (istat)
              END IF
            END IF
          END IF
          IF ( llg .AND. sphr ) THEN
            facx = facy*cos(real(y(i1,i2),8)*d2r)
            dxdpl = dxdpl*facx
            dydpl = dydpl*facy
            dxdql = dxdql*facx
            dydql = dydql*facy
          END IF
          gsqrl = dxdpl*dydql - dxdql*dydpl
        END IF
        IF ( gsqrl .LT. zero ) THEN
          istat = 1
          WRITE(0,'(/1A,1A)') 'W3CGDM ERROR -- ', &
               'input coordinates do not define a '// &
               'right-handed coordinate system'
          WRITE(0,'(1A,2A6,5A16)') 'W3CGDM ERROR --', &
               'P','Q','GSQRL','DXDPL','DYDQL','DXDQL','DYDPL'
          WRITE(0,'(1A,2I6,5E16.8/)') 'W3CGDM ERROR --', &
               p,q,gsqrl,dxdpl,dydql,dxdql,dydpl
          IF ( PRESENT(rc) ) THEN
            rc = istat
            RETURN
          ELSE
            CALL extcde (istat)
          END IF
        END IF
        gppcl = dxdpl*dxdpl + dydpl*dydpl
        gqqcl = dxdql*dxdql + dydql*dydql
        gpqcl = dxdpl*dxdql + dydpl*dydql
        gsqrl = max(gsqrl,small)
        gppcl = max(gppcl,small)
        gqqcl = max(gqqcl,small)
        dpdxl = dydql/gsqrl
        dpdyl =-dxdql/gsqrl
        dqdxl =-dydpl/gsqrl
        dqdyl = dxdpl/gsqrl
        appcl = dpdxl*dpdxl + dpdyl*dpdyl
        aqqcl = dqdxl*dqdxl + dqdyl*dqdyl
        apqcl = dpdxl*dqdxl + dpdyl*dqdyl
        hpfcl = sqrt(gppcl)
        hqfcl = sqrt(gqqcl)
        cosal = gpqcl/(hpfcl*hqfcl)
        sinal = gsqrl**2/(gppcl*gqqcl)
        costp = dxdpl/hpfcl
        sintp = dydpl/hqfcl
        coscl = sinal*costp + cosal*sintp
        sincl = sinal*sintp - cosal*costp
        angll = atan2(sincl,coscl)*r2d
        IF (PRESENT(gppc)) gppc(i1,i2) = gppcl
        IF (PRESENT(gqqc)) gqqc(i1,i2) = gqqcl
        IF (PRESENT(gpqc)) gpqc(i1,i2) = gpqcl
        IF (PRESENT(appc)) appc(i1,i2) = appcl
        IF (PRESENT(aqqc)) aqqc(i1,i2) = aqqcl
        IF (PRESENT(apqc)) apqc(i1,i2) = apqcl
        IF (PRESENT(gsqr)) gsqr(i1,i2) = gsqrl
        IF (PRESENT(hpfc)) hpfc(i1,i2) = hpfcl
        IF (PRESENT(hqfc)) hqfc(i1,i2) = hqfcl
        IF (PRESENT(dxdp)) dxdp(i1,i2) = dxdpl
        IF (PRESENT(dydp)) dydp(i1,i2) = dydpl
        IF (PRESENT(dxdq)) dxdq(i1,i2) = dxdql
        IF (PRESENT(dydq)) dydq(i1,i2) = dydql
        IF (PRESENT(dpdx)) dpdx(i1,i2) = dpdxl
        IF (PRESENT(dpdy)) dpdy(i1,i2) = dpdyl
        IF (PRESENT(dqdx)) dqdx(i1,i2) = dqdxl
        IF (PRESENT(dqdy)) dqdy(i1,i2) = dqdyl
        IF (PRESENT(cosa)) cosa(i1,i2) = cosal
        IF (PRESENT(cosc)) cosc(i1,i2) = coscl
        IF (PRESENT(sinc)) sinc(i1,i2) = sincl
        IF (PRESENT(angl)) angl(i1,i2) = angll
      END DO !I1
    END DO !I2
    !
    ! -------------------------------------------------------------------- /
    ! 4.  Clean up
    !
    DEALLOCATE ( k, c, k2, c2 )
 
  END SUBROUTINE w3cgdm_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3cgdm_r8( IJG, LLG, ICLO, PTILED, QTILED, &
       PRANGE, QRANGE, LBI, UBI, LBO, UBO, X, Y, &
       MASK, NFD, SPHERE, RADIUS, DX, DY, &
       GPPC, GQQC, GPQC, GSQR, &
       HPFC, HQFC, APPC, AQQC, APQC, &
       DXDP, DYDP, DXDQ, DYDQ, &
       DPDX, DPDY, DQDX, DQDY, &
       COSA, COSC, SINC, ANGL, RC )
    !     Double precision interface
    LOGICAL, INTENT(IN)   :: ijg
    LOGICAL, INTENT(IN)   :: llg
    INTEGER, INTENT(IN)   :: iclo
    LOGICAL, INTENT(IN)   :: ptiled, qtiled
    INTEGER, INTENT(IN)   :: prange(2), qrange(2)
    INTEGER, INTENT(IN)   :: lbi(2), ubi(2)
    INTEGER, INTENT(IN)   :: lbo(2), ubo(2)
    REAL(8), INTENT(IN)   :: x(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   :: y(lbi(1):ubi(1),lbi(2):ubi(2))
    LOGICAL, INTENT(IN),  OPTIONAL :: mask(lbi(1):ubi(1),lbi(2):ubi(2))
    INTEGER, INTENT(IN),  OPTIONAL :: nfd
    LOGICAL, INTENT(IN),  OPTIONAL :: sphere
    REAL(8), INTENT(IN),  OPTIONAL :: radius
    REAL(8), INTENT(IN),  OPTIONAL :: dx, dy
    REAL(8), INTENT(OUT), OPTIONAL :: gppc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: gqqc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: gpqc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: gsqr(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: hpfc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: hqfc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: appc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: aqqc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: apqc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: dxdp(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: dydp(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: dxdq(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: dydq(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: dpdx(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: dpdy(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: dqdx(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: dqdy(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: cosa(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: cosc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: sinc(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT), OPTIONAL :: angl(lbo(1):ubo(1),lbo(2):ubo(2))
    INTEGER, INTENT(OUT), OPTIONAL :: rc
 
    !     Local parameters
    INTEGER, PARAMETER :: m = 1 ! order of derivative
    REAL(8), PARAMETER :: small = 1d-15
    INTEGER :: istat=0, n, np, nq, i1, i2, p, q
    LOGICAL :: sphr
    REAL(8) :: r, facx, facy
    INTEGER, ALLOCATABLE :: k(:,:,:), k2(:,:,:)
    REAL(8), ALLOCATABLE :: c(:,:,:), c2(:,:,:)
    REAL(8) :: gppcl, gqqcl, gpqcl
    REAL(8) :: gsqrl, hpfcl, hqfcl
    REAL(8) :: appcl, aqqcl, apqcl
    REAL(8) :: dxdpl, dydpl, dxdql, dydql
    REAL(8) :: dpdxl, dpdyl, dqdxl, dqdyl
    REAL(8) :: cosal, sinal, costp, sintp, coscl, sincl, angll
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3CGDM_R8')
#endif
    ! -------------------------------------------------------------------- /
    ! 1.  Check and setup inputs
    !
    IF ( PRESENT(rc) ) rc = 0
 
    IF ( PRESENT(nfd) ) THEN
      n = nfd
    ELSE
      n = nfd_default
    END IF
    IF ( n.LE.0 .OR. mod(n,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', &
           'NFD must be even and greater than zero'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    np = prange(2) - prange(1) + 1
    nq = qrange(2) - qrange(1) + 1
 
    SELECT CASE ( iclo )
    CASE ( iclo_none, iclo_grdi, iclo_grdj, iclo_trdl, iclo_trpl )
      CONTINUE
    CASE DEFAULT
      WRITE(0,'(/1A,1A,1I2/)') 'W3CGDM ERROR -- ', &
           'unsupported ICLO: ',iclo
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END SELECT
 
    IF ( iclo.EQ.iclo_trpl .AND. mod(np,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', &
           'tripole grid closure requires NP even'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    IF ( PRESENT(sphere) ) THEN
      sphr = sphere
    ELSE
      sphr = .true.
    END IF
 
    IF ( PRESENT(radius) ) THEN
      r = radius
    ELSE
      r = rearth
    END IF
    facy = r*d2r
 
    IF ( PRESENT(dx) ) THEN
      IF ( dx.LE.zero ) THEN
        WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DX must be > 0'
        istat = 1
        IF ( PRESENT(rc) ) THEN
          rc = istat
          RETURN
        ELSE
          CALL extcde (istat)
        END IF
      END IF
    END IF
 
    IF ( PRESENT(dy) ) THEN
      IF ( dy.LE.zero ) THEN
        WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ','DY must be > 0'
        istat = 1
        IF ( PRESENT(rc) ) THEN
          rc = istat
          RETURN
        ELSE
          CALL extcde (istat)
        END IF
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Setup finite difference coefficients
    !
    ALLOCATE ( k(0:n,0:n,1:n), c(0:n,0:n,1:n), stat=istat )
    IF ( istat .NE. 0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', &
           'finite difference coeff allocation failed'
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
    CALL get_fdw3 ( n, m, k, c )
 
    ALLOCATE ( k2(0:2,0:2,1:2), c2(0:2,0:2,1:2), stat=istat )
    IF ( istat .NE. 0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3CGDM ERROR -- ', &
           'finite difference coeff allocation for N=2 failed'
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
    CALL get_fdw3 ( 2, m, k2, c2 )
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Compute optional return quantities
    !
    DO i2 = lbo(2), ubo(2)
      DO i1 = lbo(1), ubo(1)
        IF ( ijg ) THEN
          p = i1
          q = i2
        ELSE
          p = i2
          q = i1
        END IF
        IF ( PRESENT(dx) ) THEN
          dxdpl = dx
          dydpl = zero
        ELSE
          CALL dxydp( n, k, c, ijg, llg, iclo, ptiled, qtiled, &
               prange, qrange, lbi, ubi, p, q, dxdpl, dydpl, &
               mask=mask, x8=x, y8=y, rc=istat )
          IF ( istat .NE. 0 ) THEN
            IF ( PRESENT(rc) ) THEN
              rc = istat
              RETURN
            ELSE
              CALL extcde (istat)
            END IF
          END IF
        END IF
        IF ( PRESENT(dy) ) THEN
          dxdql = zero
          dydql = dy
        ELSE
          CALL dxydq( n, k, c, ijg, llg, iclo, ptiled, qtiled, &
               prange, qrange, lbi, ubi, p, q, dxdql, dydql, &
               mask=mask, x8=x, y8=y, rc=istat )
          IF ( istat .NE. 0 ) THEN
            IF ( PRESENT(rc) ) THEN
              rc = istat
              RETURN
            ELSE
              CALL extcde (istat)
            END IF
          END IF
        END IF
        IF ( llg .AND. sphr ) THEN
          facx = facy*cos(real(y(i1,i2),8)*d2r)
          dxdpl = dxdpl*facx
          dydpl = dydpl*facy
          dxdql = dxdql*facx
          dydql = dydql*facy
        END IF
        gsqrl = dxdpl*dydql - dxdql*dydpl
        IF ( gsqrl .LT. zero .AND. n .GT. 2 ) THEN
          !                 WRITE(0,'(1A,1I0,1A,1I0,1A,1I0,2A)') &
          !                 'W3CGDM WARNING -- NFD = ',N, &
          !                 ' yields GSQRL < 0 at (',P,',',Q,'):', &
          !                 ' computing metrics using NFD = 2'
          IF ( PRESENT(dx) ) THEN
            dxdpl = dx
            dydpl = zero
          ELSE
            CALL dxydp( 2, k2, c2, ijg, llg, iclo, ptiled, qtiled, &
                 prange, qrange, lbi, ubi, p, q, dxdpl, dydpl, &
                 mask=mask, x8=x, y8=y, rc=istat )
            IF ( istat .NE. 0 ) THEN
              IF ( PRESENT(rc) ) THEN
                rc = istat
                RETURN
              ELSE
                CALL extcde (istat)
              END IF
            END IF
          END IF
          IF ( PRESENT(dy) ) THEN
            dxdql = zero
            dydql = dy
          ELSE
            CALL dxydq( 2, k2, c2, ijg, llg, iclo, ptiled, qtiled, &
                 prange, qrange, lbi, ubi, p, q, dxdql, dydql, &
                 mask=mask, x8=x, y8=y, rc=istat )
            IF ( istat .NE. 0 ) THEN
              IF ( PRESENT(rc) ) THEN
                rc = istat
                RETURN
              ELSE
                CALL extcde (istat)
              END IF
            END IF
          END IF
          IF ( llg .AND. sphr ) THEN
            facx = facy*cos(real(y(i1,i2),8)*d2r)
            dxdpl = dxdpl*facx
            dydpl = dydpl*facy
            dxdql = dxdql*facx
            dydql = dydql*facy
          END IF
          gsqrl = dxdpl*dydql - dxdql*dydpl
        END IF
        IF ( gsqrl .LT. zero ) THEN
          istat = 1
          WRITE(0,'(/1A,1A)') 'W3CGDM ERROR -- ', &
               'input coordinates do not define a '// &
               'right-handed coordinate system'
          WRITE(0,'(1A,2A6,5A16)') 'W3CGDM ERROR --', &
               'P','Q','GSQRL','DXDPL','DYDQL','DXDQL','DYDPL'
          WRITE(0,'(1A,2I6,5E16.8/)') 'W3CGDM ERROR --', &
               p,q,gsqrl,dxdpl,dydql,dxdql,dydpl
          IF ( PRESENT(rc) ) THEN
            rc = istat
            RETURN
          ELSE
            CALL extcde (istat)
          END IF
        END IF
        gppcl = dxdpl*dxdpl + dydpl*dydpl
        gqqcl = dxdql*dxdql + dydql*dydql
        gpqcl = dxdpl*dxdql + dydpl*dydql
        gsqrl = max(gsqrl,small)
        gppcl = max(gppcl,small)
        gqqcl = max(gqqcl,small)
        dpdxl = dydql/gsqrl
        dpdyl =-dxdql/gsqrl
        dqdxl =-dydpl/gsqrl
        dqdyl = dxdpl/gsqrl
        appcl = dpdxl*dpdxl + dpdyl*dpdyl
        aqqcl = dqdxl*dqdxl + dqdyl*dqdyl
        apqcl = dpdxl*dqdxl + dpdyl*dqdyl
        hpfcl = sqrt(gppcl)
        hqfcl = sqrt(gqqcl)
        cosal = gpqcl/(hpfcl*hqfcl)
        sinal = gsqrl**2/(gppcl*gqqcl)
        costp = dxdpl/hpfcl
        sintp = dydpl/hqfcl
        coscl = sinal*costp + cosal*sintp
        sincl = sinal*sintp - cosal*costp
        angll = atan2(sincl,coscl)*r2d
        IF (PRESENT(gppc)) gppc(i1,i2) = gppcl
        IF (PRESENT(gqqc)) gqqc(i1,i2) = gqqcl
        IF (PRESENT(gpqc)) gpqc(i1,i2) = gpqcl
        IF (PRESENT(appc)) appc(i1,i2) = appcl
        IF (PRESENT(aqqc)) aqqc(i1,i2) = aqqcl
        IF (PRESENT(apqc)) apqc(i1,i2) = apqcl
        IF (PRESENT(gsqr)) gsqr(i1,i2) = gsqrl
        IF (PRESENT(hpfc)) hpfc(i1,i2) = hpfcl
        IF (PRESENT(hqfc)) hqfc(i1,i2) = hqfcl
        IF (PRESENT(dxdp)) dxdp(i1,i2) = dxdpl
        IF (PRESENT(dydp)) dydp(i1,i2) = dydpl
        IF (PRESENT(dxdq)) dxdq(i1,i2) = dxdql
        IF (PRESENT(dydq)) dydq(i1,i2) = dydql
        IF (PRESENT(dpdx)) dpdx(i1,i2) = dpdxl
        IF (PRESENT(dpdy)) dpdy(i1,i2) = dpdyl
        IF (PRESENT(dqdx)) dqdx(i1,i2) = dqdxl
        IF (PRESENT(dqdy)) dqdy(i1,i2) = dqdyl
        IF (PRESENT(cosa)) cosa(i1,i2) = cosal
        IF (PRESENT(cosc)) cosc(i1,i2) = coscl
        IF (PRESENT(sinc)) sinc(i1,i2) = sincl
        IF (PRESENT(angl)) angl(i1,i2) = atan2(sincl,coscl)*r2d
        IF (PRESENT(angl)) angl(i1,i2) = angll
      END DO !I1
    END DO !I2
    !
    ! -------------------------------------------------------------------- /
    ! 4.  Clean up
    !
    DEALLOCATE ( k, c, k2, c2 )
 
  END SUBROUTINE w3cgdm_r8
  !/
  !/ End of W3CGDM ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3GRD0( NFD, IJG, ICLO, PTILED, QTILED, &
  !/                       PRANGE, QRANGE, LBI, UBI, LBO, UBO, &
  !/                       DPDX, DPDY, DQDX, DQDY, &
  !/                       F, DFDX, DFDY, MASK, RC )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute gradient of a scalar field F(x,y) defined on a
  !     curvilinear coordinate grid (x(p,q),y(p,q)).
  !
  !  2. Method :
  !
  !     Compute derivatives using finite-difference method.
  !     Apply curvilinear grid metric.
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       NFD     Int.   I   Finite-difference order (even)
  !       IJG     Log.   I   Logical flag indicating ordering of input
  !                          coord. arrays: T = (NP,NQ) and F = (NP,NQ)
  !       ICLO    Int.   I   Parameter indicating type of index space closure.
  !       PTILED  Log.   I   Logical flag indicating that input arrays are tiled
  !                          in P-axis with halos of width >= NFD/2
  !       QTILED  Log.   I   Logical flag indicating that input arrays are tiled
  !                          in Q-axis with halos of width >= NFD/2
  !       PRANGE  I.A.   I   Range of P index coordinate: P in [PRANGE(1),PRANGE(2)]
  !       QRANGE  I.A.   I   Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)]
  !       LBI     I.A.   I   Lower-bound of  input arrays, DIMENSION(2)
  !       UBI     I.A.   I   Upper-bound of  input arrays, DIMENSION(2)
  !       LBO     I.A.   I   Lower-bound of output arrays, DIMENSION(2)
  !       UBO     I.A.   I   Upper-bound of output arrays, DIMENSION(2)
  !       DPDX    R.A.   I   dp/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DPDY    R.A.   I   dp/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DQDX    R.A.   I   dq/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DQDY    R.A.   I   dq/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       F       R.A.   I   Scalar input field, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DFDX    R.A.   O   df/dx, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       DFDY    R.A.   O   df/dy, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       MASK    L.A.   I   OPTIONAL logical mask (T = invalid, F = valid)
  !                          DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       RC      Int.   O   OPTIONAL return code (!= 0 if error occurs)
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !     - If RC is not provided and an error occurs, then the routine will
  !       report error to stderr and attempt to abort the calling program.
  !     - When MASK is specified, points that are masked are excluded from
  !       the finite-difference stencil.  In order to avoid reaching across
  !       masked regions, the stencil is modified to one-sided and/or the
  !       finite-difference order is reduced.  If the masking results in a
  !       single point wide channel, then the derivative in the direction
  !       across the channel is set to zero.
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3grd0_r4( NFD, IJG, ICLO, PTILED, QTILED, &
       PRANGE, QRANGE, LBI, UBI, LBO, UBO, &
       DPDX, DPDY, DQDX, DQDY, &
       F, DFDX, DFDY, MASK, RC )
    !     Single precision interface
    INTEGER, INTENT(IN)   :: nfd
    LOGICAL, INTENT(IN)   :: ijg
    INTEGER, INTENT(IN)   :: iclo
    LOGICAL, INTENT(IN)   :: ptiled, qtiled
    INTEGER, INTENT(IN)   :: prange(2), qrange(2)
    INTEGER, INTENT(IN)   :: lbi(2), ubi(2)
    INTEGER, INTENT(IN)   :: lbo(2), ubo(2)
    REAL(4), INTENT(IN)   :: dpdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   :: dpdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   :: dqdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   :: dqdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   ::    f(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(OUT)  :: dfdx(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT)  :: dfdy(lbo(1):ubo(1),lbo(2):ubo(2))
    LOGICAL, INTENT(IN),  OPTIONAL :: mask(lbi(1):ubi(1),lbi(2):ubi(2))
    INTEGER, INTENT(OUT), OPTIONAL :: rc
 
    !     Local parameters
    INTEGER, PARAMETER :: m = 1 ! order of derivative
    INTEGER :: np, nq, i1, i2, p, q
    INTEGER :: istat=0
    INTEGER :: k(0:nfd,0:nfd,1:nfd)
    REAL(8) :: c(0:nfd,0:nfd,1:nfd)
    REAL(8) :: dfdp, dfdq
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GRD0_R4')
#endif
    ! -------------------------------------------------------------------- /
    ! 1.  Check and setup inputs
    !
    IF ( PRESENT(rc) ) rc = 0
 
    IF ( nfd.LE.0 .OR. mod(nfd,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', &
           'NFD must be even and greater than zero'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    np = prange(2) - prange(1) + 1
    nq = qrange(2) - qrange(1) + 1
 
    SELECT CASE ( iclo )
    CASE ( iclo_none, iclo_grdi, iclo_grdj, iclo_trdl, iclo_trpl )
      CONTINUE
    CASE DEFAULT
      WRITE(0,'(/1A,1A,1I2/)') 'W3GRD0 ERROR -- ', &
           'unsupported ICLO: ',iclo
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END SELECT
 
    IF ( iclo.EQ.iclo_trpl .AND. mod(np,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', &
           'tripole grid closure requires NP even'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Setup finite difference coefficients
    !
    CALL get_fdw3 ( nfd, m, k, c )
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Compute dF/dx & dF/dy
    !
    DO i2 = lbo(2), ubo(2)
      DO i1 = lbo(1), ubo(1)
        IF ( PRESENT(mask) ) THEN
          IF ( mask(i1,i2) ) cycle
        END IF
        IF ( ijg ) THEN
          p = i1
          q = i2
        ELSE
          p = i2
          q = i1
        END IF
        CALL dfdpq ( nfd, k, c, ijg, iclo, ptiled, qtiled, &
             prange, qrange, lbi, ubi, p, q, &
             f4=f, dfdp=dfdp, dfdq=dfdq, &
             mask=mask, rc=istat )
        IF ( istat .NE. 0 ) THEN
          IF ( PRESENT(rc) ) THEN
            rc = istat
            RETURN
          ELSE
            CALL extcde (istat)
          END IF
        END IF
        dfdx(i1,i2) = dfdp*dpdx(i1,i2) + dfdq*dqdx(i1,i2)
        dfdy(i1,i2) = dfdp*dpdy(i1,i2) + dfdq*dqdy(i1,i2)
      END DO !I1
    END DO !I2
 
  END SUBROUTINE w3grd0_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3grd0_r8( NFD, IJG, ICLO, PTILED, QTILED, &
       PRANGE, QRANGE, LBI, UBI, LBO, UBO, &
       DPDX, DPDY, DQDX, DQDY, &
       F, DFDX, DFDY, MASK, RC )
    !     Double precision interface
    INTEGER, INTENT(IN)   :: nfd
    LOGICAL, INTENT(IN)   :: ijg
    INTEGER, INTENT(IN)   :: iclo
    LOGICAL, INTENT(IN)   :: ptiled, qtiled
    INTEGER, INTENT(IN)   :: prange(2), qrange(2)
    INTEGER, INTENT(IN)   :: lbi(2), ubi(2)
    INTEGER, INTENT(IN)   :: lbo(2), ubo(2)
    REAL(8), INTENT(IN)   :: dpdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   :: dpdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   :: dqdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   :: dqdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   ::    f(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(OUT)  :: dfdx(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT)  :: dfdy(lbo(1):ubo(1),lbo(2):ubo(2))
    LOGICAL, INTENT(IN),  OPTIONAL :: mask(lbi(1):ubi(1),lbi(2):ubi(2))
    INTEGER, INTENT(OUT), OPTIONAL :: rc
 
    !     Local parameters
    INTEGER, PARAMETER :: m = 1 ! order of derivative
    INTEGER :: np, nq, i1, i2, p, q
    INTEGER :: istat=0
    INTEGER :: k(0:nfd,0:nfd,1:nfd)
    REAL(8) :: c(0:nfd,0:nfd,1:nfd)
    REAL(8) :: dfdp, dfdq
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GRD0_R8')
#endif
    ! -------------------------------------------------------------------- /
    ! 1.  Check and setup inputs
    !
    IF ( PRESENT(rc) ) rc = 0
 
    IF ( nfd.LE.0 .OR. mod(nfd,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', &
           'NFD must be even and greater than zero'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    np = prange(2) - prange(1) + 1
    nq = qrange(2) - qrange(1) + 1
 
    SELECT CASE ( iclo )
    CASE ( iclo_none, iclo_grdi, iclo_grdj, iclo_trdl, iclo_trpl )
      CONTINUE
    CASE DEFAULT
      WRITE(0,'(/1A,1A,1I2/)') 'W3GRD0 ERROR -- ', &
           'unsupported ICLO: ',iclo
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END SELECT
 
    IF ( iclo.EQ.iclo_trpl .AND. mod(np,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', &
           'tripole grid closure requires NP even'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Setup finite difference coefficients
    !
    CALL get_fdw3 ( nfd, m, k, c )
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Compute dF/dx & dF/dy
    !
    DO i2 = lbo(2), ubo(2)
      DO i1 = lbo(1), ubo(1)
        IF ( PRESENT(mask) ) THEN
          IF ( mask(i1,i2) ) cycle
        END IF
        IF ( ijg ) THEN
          p = i1
          q = i2
        ELSE
          p = i2
          q = i1
        END IF
        CALL dfdpq ( nfd, k, c, ijg, iclo, ptiled, qtiled, &
             prange, qrange, lbi, ubi, p, q, &
             f8=f, dfdp=dfdp, dfdq=dfdq, &
             mask=mask, rc=istat )
        IF ( istat .NE. 0 ) THEN
          IF ( PRESENT(rc) ) THEN
            rc = istat
            RETURN
          ELSE
            CALL extcde (istat)
          END IF
        END IF
        dfdx(i1,i2) = dfdp*dpdx(i1,i2) + dfdq*dqdx(i1,i2)
        dfdy(i1,i2) = dfdp*dpdy(i1,i2) + dfdq*dqdy(i1,i2)
      END DO !I1
    END DO !I2
 
  END SUBROUTINE w3grd0_r8
  !/
  !/ End of W3GRD0 ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3DIV1( NFD, IJG, ICLO, PTILED, QTILED, &
  !/                       PRANGE, QRANGE, LBI, UBI, LBO, UBO, &
  !/                       DPDX, DPDY, DQDX, DQDY, &
  !/                       VX, VY, DIVV, MASK, RC )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute divergence of a vector field (V_x,V_y) defined
  !     on a curvilinear coordinate grid (x(p,q),y(p,q)).
  !
  !  2. Method :
  !
  !     Compute derivatives using finite-difference method.
  !     Apply curvilinear grid metric.
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       NFD     Int.   I   Finite-difference order (even)
  !       IJG     Log.   I   Logical flag indicating ordering of input
  !                          coord. arrays: T = (NP,NQ) and F = (NP,NQ)
  !       ICLO    Int.   I   Parameter indicating type of index space closure.
  !       PTILED  Log.   I   Logical flag indicating that input arrays are tiled
  !                          in P-axis with halos of width >= NFD/2
  !       QTILED  Log.   I   Logical flag indicating that input arrays are tiled
  !                          in Q-axis with halos of width >= NFD/2
  !       PRANGE  I.A.   I   Range of P index coordinate: P in [PRANGE(1),PRANGE(2)]
  !       QRANGE  I.A.   I   Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)]
  !       LBI     I.A.   I   Lower-bound of  input arrays, DIMENSION(2)
  !       UBI     I.A.   I   Upper-bound of  input arrays, DIMENSION(2)
  !       LBO     I.A.   I   Lower-bound of output arrays, DIMENSION(2)
  !       UBO     I.A.   I   Upper-bound of output arrays, DIMENSION(2)
  !       DPDX    R.A.   I   dp/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DPDY    R.A.   I   dp/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DQDX    R.A.   I   dq/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DQDY    R.A.   I   dq/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       VX      R.A.   I   x-component of input vector field,
  !                          DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       VY      R.A.   I   y-component of input vector field,
  !                          DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DIVV    R.A.   O   div(V), DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       MASK    L.A.   I   OPTIONAL logical mask (T = invalid, F = valid)
  !                          DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       RC      Int.   O   OPTIONAL return code (!= 0 if error occurs)
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !     - If RC is not provided and an error occurs, then the routine will
  !       report error to stderr and attempt to abort the calling program.
  !     - When MASK is specified, points that are masked are excluded from
  !       the finite-difference stencil.  In order to avoid reaching across
  !       masked regions, the stencil is modified to one-sided and/or the
  !       finite-difference order is reduced.  If the masking results in a
  !       single point wide channel, then the derivative in the direction
  !       across the channel is set to zero.
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3div1_r4( NFD, IJG, ICLO, PTILED, QTILED, &
       PRANGE, QRANGE, LBI, UBI, LBO, UBO, &
       DPDX, DPDY, DQDX, DQDY, &
       VX, VY, DIVV, MASK, RC )
    !     Single precision interface
    INTEGER, INTENT(IN)   :: nfd
    LOGICAL, INTENT(IN)   :: ijg
    INTEGER, INTENT(IN)   :: iclo
    LOGICAL, INTENT(IN)   :: ptiled, qtiled
    INTEGER, INTENT(IN)   :: prange(2), qrange(2)
    INTEGER, INTENT(IN)   :: lbi(2), ubi(2)
    INTEGER, INTENT(IN)   :: lbo(2), ubo(2)
    REAL(4), INTENT(IN)   :: dpdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   :: dpdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   :: dqdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   :: dqdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   ::   vx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   ::   vy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(OUT)  :: divv(lbo(1):ubo(1),lbo(2):ubo(2))
    LOGICAL, INTENT(IN),  OPTIONAL :: mask(lbi(1):ubi(1),lbi(2):ubi(2))
    INTEGER, INTENT(OUT), OPTIONAL :: rc
 
    !     Local parameters
    INTEGER, PARAMETER :: m = 1 ! order of derivative
    INTEGER :: np, nq, i1, i2, p, q
    INTEGER :: istat=0
    INTEGER :: k(0:nfd,0:nfd,1:nfd)
    REAL(8) :: c(0:nfd,0:nfd,1:nfd)
    REAL(8) :: dvxdp, dvxdq, dvydp, dvydq
    REAL(8) :: dvxdx, dvydy
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3DIV1_R4')
#endif
    ! -------------------------------------------------------------------- /
    ! 1.  Check and setup inputs
    !
    IF ( PRESENT(rc) ) rc = 0
 
    IF ( nfd.LE.0 .OR. mod(nfd,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3DIV1 ERROR -- ', &
           'NFD must be even and greater than zero'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    np = prange(2) - prange(1) + 1
    nq = qrange(2) - qrange(1) + 1
 
    SELECT CASE ( iclo )
    CASE ( iclo_none, iclo_grdi, iclo_grdj, iclo_trdl, iclo_trpl )
      CONTINUE
    CASE DEFAULT
      WRITE(0,'(/1A,1A,1I2/)') 'W3DIV1 ERROR -- ', &
           'unsupported ICLO: ',iclo
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END SELECT
 
    IF ( iclo.EQ.iclo_trpl .AND. mod(np,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3DIV1 ERROR -- ', &
           'tripole grid closure requires NP even'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Setup finite difference coefficients
    !
    CALL get_fdw3 ( nfd, m, k, c )
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Compute div(V) = dV_x/dx + dV_y/dy
    !
    DO i2 = lbo(2), ubo(2)
      DO i1 = lbo(1), ubo(1)
        IF ( PRESENT(mask) ) THEN
          IF ( mask(i1,i2) ) cycle
        END IF
        IF ( ijg ) THEN
          p = i1
          q = i2
        ELSE
          p = i2
          q = i1
        END IF
        CALL dfdpq ( nfd, k, c, ijg, iclo, ptiled, qtiled, &
             prange, qrange, lbi, ubi, p, q, &
             f4=vx, dfdp=dvxdp, dfdq=dvxdq, &
             g4=vy, dgdp=dvydp, dgdq=dvydq, &
             mask=mask, rc=istat )
        IF ( istat .NE. 0 ) THEN
          IF ( PRESENT(rc) ) THEN
            rc = istat
            RETURN
          ELSE
            CALL extcde (istat)
          END IF
        END IF
        dvxdx = dvxdp*dpdx(i1,i2) + dvxdq*dqdx(i1,i2)
        dvydy = dvydp*dpdy(i1,i2) + dvydq*dqdy(i1,i2)
        divv(i1,i2) = dvxdx + dvydy
      END DO !I1
    END DO !I2
 
  END SUBROUTINE w3div1_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3div1_r8( NFD, IJG, ICLO, PTILED, QTILED, &
       PRANGE, QRANGE, LBI, UBI, LBO, UBO, &
       DPDX, DPDY, DQDX, DQDY, &
       VX, VY, DIVV, MASK, RC )
    !     Double precision interface
    INTEGER, INTENT(IN)   :: nfd
    LOGICAL, INTENT(IN)   :: ijg
    INTEGER, INTENT(IN)   :: iclo
    LOGICAL, INTENT(IN)   :: ptiled, qtiled
    INTEGER, INTENT(IN)   :: prange(2), qrange(2)
    INTEGER, INTENT(IN)   :: lbi(2), ubi(2)
    INTEGER, INTENT(IN)   :: lbo(2), ubo(2)
    REAL(8), INTENT(IN)   :: dpdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   :: dpdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   :: dqdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   :: dqdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   ::   vx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   ::   vy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(OUT)  :: divv(lbo(1):ubo(1),lbo(2):ubo(2))
    LOGICAL, INTENT(IN),  OPTIONAL :: mask(lbi(1):ubi(1),lbi(2):ubi(2))
    INTEGER, INTENT(OUT), OPTIONAL :: rc
 
    !     Local parameters
    INTEGER, PARAMETER :: m = 1 ! order of derivative
    INTEGER :: np, nq, i1, i2, p, q
    INTEGER :: istat=0
    INTEGER :: k(0:nfd,0:nfd,1:nfd)
    REAL(8) :: c(0:nfd,0:nfd,1:nfd)
    REAL(8) :: dvxdp, dvxdq, dvydp, dvydq
    REAL(8) :: dvxdx, dvydy
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3DIV1_R8')
#endif
    ! -------------------------------------------------------------------- /
    ! 1.  Check and setup inputs
    !
    IF ( PRESENT(rc) ) rc = 0
 
    IF ( nfd.LE.0 .OR. mod(nfd,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', &
           'NFD must be even and greater than zero'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    np = prange(2) - prange(1) + 1
    nq = qrange(2) - qrange(1) + 1
 
    SELECT CASE ( iclo )
    CASE ( iclo_none, iclo_grdi, iclo_grdj, iclo_trdl, iclo_trpl )
      CONTINUE
    CASE DEFAULT
      WRITE(0,'(/1A,1A,1I2/)') 'W3GRD0 ERROR -- ', &
           'unsupported ICLO: ',iclo
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END SELECT
 
    IF ( iclo.EQ.iclo_trpl .AND. mod(np,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3GRD0 ERROR -- ', &
           'tripole grid closure requires NP even'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Setup finite difference coefficients
    !
    CALL get_fdw3 ( nfd, m, k, c )
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Compute div(V) = dV_x/dx + dV_y/dy
    !
    DO i2 = lbo(2), ubo(2)
      DO i1 = lbo(1), ubo(1)
        IF ( PRESENT(mask) ) THEN
          IF ( mask(i1,i2) ) cycle
        END IF
        IF ( ijg ) THEN
          p = i1
          q = i2
        ELSE
          p = i2
          q = i1
        END IF
        CALL dfdpq ( nfd, k, c, ijg, iclo, ptiled, qtiled, &
             prange, qrange, lbi, ubi, p, q, &
             f8=vx, dfdp=dvxdp, dfdq=dvxdq, &
             g8=vy, dgdp=dvydp, dgdq=dvydq, &
             mask=mask, rc=istat )
        IF ( istat .NE. 0 ) THEN
          IF ( PRESENT(rc) ) THEN
            rc = istat
            RETURN
          ELSE
            CALL extcde (istat)
          END IF
        END IF
        dvxdx = dvxdp*dpdx(i1,i2) + dvxdq*dqdx(i1,i2)
        dvydy = dvydp*dpdy(i1,i2) + dvydq*dqdy(i1,i2)
        divv(i1,i2) = dvxdx + dvydy
      END DO !I1
    END DO !I2
 
  END SUBROUTINE w3div1_r8
  !/
  !/ End of W3DIV1 ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3DIV2( NFD, IJG, ICLO, PTILED, QTILED, &
  !/                       PRANGE, QRANGE, LBI, UBI, LBO, UBO, &
  !/                       DPDX, DPDY, DQDX, DQDY, &
  !/                       SXX, SYY, SXY, DSX, DSY, MASK, RC )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute divergence of a rank 2 symmetric tensor field (S_xx,S_yy,S_xy)
  !     defined on a curvilinear coordinate grid (x(p,q),y(p,q)).
  !
  !  2. Method :
  !
  !     Compute derivatives using finite-difference method.
  !     Apply curvilinear grid metric.
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       NFD     Int.   I   Finite-difference order (even)
  !       IJG     Log.   I   Logical flag indicating ordering of input
  !                          coord. arrays: T = (NP,NQ) and F = (NP,NQ)
  !       ICLO    Int.   I   Parameter indicating type of index space closure.
  !       PTILED  Log.   I   Logical flag indicating that input arrays are tiled
  !                          in P-axis with halos of width >= NFD/2
  !       QTILED  Log.   I   Logical flag indicating that input arrays are tiled
  !                          in Q-axis with halos of width >= NFD/2
  !       PRANGE  I.A.   I   Range of P index coordinate: P in [PRANGE(1),PRANGE(2)]
  !       QRANGE  I.A.   I   Range of Q index coordinate: Q in [QRANGE(1),QRANGE(2)]
  !       LBI     I.A.   I   Lower-bound of  input arrays, DIMENSION(2)
  !       UBI     I.A.   I   Upper-bound of  input arrays, DIMENSION(2)
  !       LBO     I.A.   I   Lower-bound of output arrays, DIMENSION(2)
  !       UBO     I.A.   I   Upper-bound of output arrays, DIMENSION(2)
  !       DPDX    R.A.   I   dp/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DPDY    R.A.   I   dp/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DQDX    R.A.   I   dq/dx, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DQDY    R.A.   I   dq/dy, DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       SXX     R.A.   I   xx-component of input tensor field,
  !                          DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       SYY     R.A.   I   yy-component of input vector field,
  !                          DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       SXY     R.A.   I   xy-component of input vector field,
  !                          DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       DSX     R.A.   O   div(S)_x, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       DSY     R.A.   O   div(S)_y, DIMENSION(LBO(1):UBO(1),LBO(2):UBO(2))
  !       MASK    L.A.   I   OPTIONAL logical mask (T = invalid, F = valid)
  !                          DIMENSION(LBI(1):UBI(1),LBI(2):UBI(2))
  !       RC      Int.   O   OPTIONAL return code (!= 0 if error occurs)
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !     - If RC is not provided and an error occurs, then the routine will
  !       report error to stderr and attempt to abort the calling program.
  !     - When MASK is specified, points that are masked are excluded from
  !       the finite-difference stencil.  In order to avoid reaching across
  !       masked regions, the stencil is modified to one-sided and/or the
  !       finite-difference order is reduced.  If the masking results in a
  !       single point wide channel, then the derivative in the direction
  !       across the channel is set to zero.
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3div2_r4( NFD, IJG, ICLO, PTILED, QTILED, &
       PRANGE, QRANGE, LBI, UBI, LBO, UBO, &
       DPDX, DPDY, DQDX, DQDY, &
       SXX, SYY, SXY, DSX, DSY, MASK, RC )
    !     Single precision interface
    INTEGER, INTENT(IN)   :: nfd
    LOGICAL, INTENT(IN)   :: ijg
    INTEGER, INTENT(IN)   :: iclo
    LOGICAL, INTENT(IN)   :: ptiled, qtiled
    INTEGER, INTENT(IN)   :: prange(2), qrange(2)
    INTEGER, INTENT(IN)   :: lbi(2), ubi(2)
    INTEGER, INTENT(IN)   :: lbo(2), ubo(2)
    REAL(4), INTENT(IN)   :: dpdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   :: dpdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   :: dqdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   :: dqdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   ::  sxx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   ::  syy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(IN)   ::  sxy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(4), INTENT(OUT)  ::  dsx(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(4), INTENT(OUT)  ::  dsy(lbo(1):ubo(1),lbo(2):ubo(2))
    LOGICAL, INTENT(IN),  OPTIONAL :: mask(lbi(1):ubi(1),lbi(2):ubi(2))
    INTEGER, INTENT(OUT), OPTIONAL :: rc
 
    !     Local parameters
    INTEGER, PARAMETER :: m = 1 ! order of derivative
    INTEGER :: np, nq, i1, i2, p, q
    INTEGER :: istat=0
    INTEGER :: k(0:nfd,0:nfd,1:nfd)
    REAL(8) :: c(0:nfd,0:nfd,1:nfd)
    REAL(8) :: dxxdp, dxxdq, dyydp, dyydq, dxydp, dxydq
    REAL(8) :: dxxdx, dyydy, dxydx, dxydy
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3DIV2_R4')
#endif
    ! -------------------------------------------------------------------- /
    ! 1.  Check and setup inputs
    !
    IF ( PRESENT(rc) ) rc = 0
 
    IF ( nfd.LE.0 .OR. mod(nfd,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', &
           'NFD must be even and greater than zero'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    np = prange(2) - prange(1) + 1
    nq = qrange(2) - qrange(1) + 1
 
    SELECT CASE ( iclo )
    CASE ( iclo_none, iclo_grdi, iclo_grdj, iclo_trdl, iclo_trpl )
      CONTINUE
    CASE DEFAULT
      WRITE(0,'(/1A,1A,1I2/)') 'W3DIV2 ERROR -- ', &
           'unsupported ICLO: ',iclo
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END SELECT
 
    IF ( iclo.EQ.iclo_trpl .AND. mod(np,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', &
           'tripole grid closure requires NP even'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Setup finite difference coefficients
    !
    CALL get_fdw3 ( nfd, m, k, c )
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Compute div(S) = (dS_xx/dx + dS_xy/dy, dS_xy/dx + dS_yy/dy)
    !
    DO i2 = lbo(2), ubo(2)
      DO i1 = lbo(1), ubo(1)
        IF ( PRESENT(mask) ) THEN
          IF ( mask(i1,i2) ) cycle
        END IF
        IF ( ijg ) THEN
          p = i1
          q = i2
        ELSE
          p = i2
          q = i1
        END IF
        CALL dfdpq ( nfd, k, c, ijg, iclo, ptiled, qtiled, &
             prange, qrange, lbi, ubi, p, q, &
             f4=sxx, dfdp=dxxdp, dfdq=dxxdq, &
             g4=syy, dgdp=dyydp, dgdq=dyydq, &
             h4=sxy, dhdp=dxydp, dhdq=dxydq, &
             mask=mask, rc=istat )
        IF ( istat .NE. 0 ) THEN
          IF ( PRESENT(rc) ) THEN
            rc = istat
            RETURN
          ELSE
            CALL extcde (istat)
          END IF
        END IF
        dxxdx = dxxdp*dpdx(i1,i2) + dxxdq*dqdx(i1,i2)
        dyydy = dyydp*dpdy(i1,i2) + dyydq*dqdy(i1,i2)
        dxydx = dxydp*dpdx(i1,i2) + dxydq*dqdx(i1,i2)
        dxydy = dxydp*dpdy(i1,i2) + dxydq*dqdy(i1,i2)
        dsx(i1,i2) = dxxdx + dxydy
        dsy(i1,i2) = dxydx + dyydy
      END DO !I1
    END DO !I2
 
  END SUBROUTINE w3div2_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3div2_r8( NFD, IJG, ICLO, PTILED, QTILED, &
       PRANGE, QRANGE, LBI, UBI, LBO, UBO, &
       DPDX, DPDY, DQDX, DQDY, &
       SXX, SYY, SXY, DSX, DSY, MASK, RC )
    !     Double precision interface
    INTEGER, INTENT(IN)   :: nfd
    LOGICAL, INTENT(IN)   :: ijg
    INTEGER, INTENT(IN)   :: iclo
    LOGICAL, INTENT(IN)   :: ptiled, qtiled
    INTEGER, INTENT(IN)   :: prange(2), qrange(2)
    INTEGER, INTENT(IN)   :: lbi(2), ubi(2)
    INTEGER, INTENT(IN)   :: lbo(2), ubo(2)
    REAL(8), INTENT(IN)   :: dpdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   :: dpdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   :: dqdx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   :: dqdy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   ::  sxx(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   ::  syy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(IN)   ::  sxy(lbi(1):ubi(1),lbi(2):ubi(2))
    REAL(8), INTENT(OUT)  ::  dsx(lbo(1):ubo(1),lbo(2):ubo(2))
    REAL(8), INTENT(OUT)  ::  dsy(lbo(1):ubo(1),lbo(2):ubo(2))
    LOGICAL, INTENT(IN),  OPTIONAL :: mask(lbi(1):ubi(1),lbi(2):ubi(2))
    INTEGER, INTENT(OUT), OPTIONAL :: rc
 
    !     Local parameters
    INTEGER, PARAMETER :: m = 1 ! order of derivative
    INTEGER :: np, nq, i1, i2, p, q
    INTEGER :: istat=0
    INTEGER :: k(0:nfd,0:nfd,1:nfd)
    REAL(8) :: c(0:nfd,0:nfd,1:nfd)
    REAL(8) :: dxxdp, dxxdq, dyydp, dyydq, dxydp, dxydq
    REAL(8) :: dxxdx, dyydy, dxydx, dxydy
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3DIV2_R8')
#endif
    ! -------------------------------------------------------------------- /
    ! 1.  Check and setup inputs
    !
    IF ( PRESENT(rc) ) rc = 0
 
    IF ( nfd.LE.0 .OR. mod(nfd,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', &
           'NFD must be even and greater than zero'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    np = prange(2) - prange(1) + 1
    nq = qrange(2) - qrange(1) + 1
 
    SELECT CASE ( iclo )
    CASE ( iclo_none, iclo_grdi, iclo_grdj, iclo_trdl, iclo_trpl )
      CONTINUE
    CASE DEFAULT
      WRITE(0,'(/1A,1A,1I2/)') 'W3DIV2 ERROR -- ', &
           'unsupported ICLO: ',iclo
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END SELECT
 
    IF ( iclo.EQ.iclo_trpl .AND. mod(np,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3DIV2 ERROR -- ', &
           'tripole grid closure requires NP even'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Setup finite difference coefficients
    !
    CALL get_fdw3 ( nfd, m, k, c )
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Compute div(S) = (dS_xx/dx + dS_xy/dy, dS_xy/dx + dS_yy/dy)
    !
    DO i2 = lbo(2), ubo(2)
      DO i1 = lbo(1), ubo(1)
        IF ( PRESENT(mask) ) THEN
          IF ( mask(i1,i2) ) cycle
        END IF
        IF ( ijg ) THEN
          p = i1
          q = i2
        ELSE
          p = i2
          q = i1
        END IF
        CALL dfdpq ( nfd, k, c, ijg, iclo, ptiled, qtiled, &
             prange, qrange, lbi, ubi, p, q, &
             f8=sxx, dfdp=dxxdp, dfdq=dxxdq, &
             g8=syy, dgdp=dyydp, dgdq=dyydq, &
             h8=sxy, dhdp=dxydp, dhdq=dxydq, &
             mask=mask, rc=istat )
        IF ( istat .NE. 0 ) THEN
          IF ( PRESENT(rc) ) THEN
            rc = istat
            RETURN
          ELSE
            CALL extcde (istat)
          END IF
        END IF
        dxxdx = dxxdp*dpdx(i1,i2) + dxxdq*dqdx(i1,i2)
        dyydy = dyydp*dpdy(i1,i2) + dyydq*dqdy(i1,i2)
        dxydx = dxydp*dpdx(i1,i2) + dxydq*dqdx(i1,i2)
        dxydy = dxydp*dpdy(i1,i2) + dxydq*dqdy(i1,i2)
        dsx(i1,i2) = dxxdx + dxydy
        dsy(i1,i2) = dxydx + dyydy
      END DO !I1
    END DO !I2
 
  END SUBROUTINE w3div2_r8
  !/
  !/ End of W3DIV2 ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3DIST( LLG, XT, YT, XS, YS ) RESULT(DIST)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute distance between two points.  If spherical grid, then
  !     distance is the angle (in degrees) between the two points.
  !
  !  2. Method :
  !
  !     Map Projections -- A Working Manual, John P. Snyder
  !     U.S. Geological Survey professional paper; 1395
  !     Chapter 5. Transformation of Map Graticules
  !
  !  3. Parameters :
  !
  !     Return parameter
  !     ----------------------------------------------------------------
  !       DIST    Real   O   Distance
  !     ----------------------------------------------------------------
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       LLG     Log.   I   Logical flag indicating the coordinate system:
  !                          T = spherical lat/lon (degrees) and F = Cartesian.
  !       XT      Real   I   X-coordinate of target point.
  !       YT      Real   I   Y-coordinate of target point.
  !       XS      Real   I   X-coordinate of source point.
  !       YS      Real   I   Y-coordinate of source point.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3dist_r4( LLG, XT, YT, XS, YS ) RESULT(DIST)
    !     Single precision interface
    REAL(4)             :: dist
    LOGICAL, INTENT(IN) :: llg
    REAL(4), INTENT(IN) :: xt, yt
    REAL(4), INTENT(IN) :: xs, ys
 
    !     Local parameters
    REAL(8) :: xt8, yt8, xs8, ys8
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3DIST_R4')
#endif
    !
    !-----set inputs
    xt8 = xt; yt8 = yt;
    xs8 = xs; ys8 = ys;
    !
    !-----call double precision method
    dist = w3dist( llg, xt8, yt8, xs8, ys8 )
 
  END FUNCTION w3dist_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
#define DIST_WITH_SINE
#define DIST_CHECK_NAN____disabled
  FUNCTION w3dist_r8( LLG, XT, YT, XS, YS ) RESULT(DIST)
    !     Double precision interface
    REAL(8)             :: dist
    LOGICAL, INTENT(IN) :: llg
    REAL(8), INTENT(IN) :: xt, yt
    REAL(8), INTENT(IN) :: xs, ys
 
    !     Local parameters
    REAL(8) :: dx, dy, slam, sphi, argd
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3DIST_R8')
#endif
    !
    !-----compute displacements
    dx = xt - xs
    dy = yt - ys
 
    IF ( llg ) THEN !spherical coordinates
      !---------check for longitudinal branch cut crossing
      IF ( abs(dx) .GT. d270 ) THEN
        dx = dx - sign(d360,dx)
      END IF
#ifdef DIST_WITH_SINE
      !---------compute angular distance using sin(d/2)
      !         (this equation is more accurate than cos(d))
      slam = sin(half*dx*d2r)
      sphi = sin(half*dy*d2r)
      argd = sqrt( cos(yt*d2r)*cos(ys*d2r)*slam*slam + sphi*sphi )
      dist = r2d*two*asin( argd )
#else
      !---------compute angular distance using cos(c) (min required
      !         for rare situation of acos(1+small) generating NaN)
      argd = min( one, cos(yt*d2r)*cos(ys*d2r)*cos(dx*d2r) &
           + sin(yt*d2r)*sin(ys*d2r) )
      dist = r2d*acos( argd )
#endif
    ELSE !cartesian coordinates
      !---------compute cartesian distance
      dist = sqrt( dx**2 + dy**2 )
    END IF !cartesian coordinates
#ifdef DIST_CHECK_NAN
    IF ( w3inan(dist) ) THEN
      WRITE(0,'(/1A/)') 'W3DIST_R8 ERROR -- result is NaN'
      CALL extcde (1)
    END IF
#endif
 
  END FUNCTION w3dist_r8
  !/
  !/ End of W3DIST ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3SPLX( LAM0, PHI0, C0, LAM, PHI, X, Y )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute Cartesian coordinates from input longitude and latitude
  !     using stereographic projection with center at (LAM0,PHI0) and
  !     "standard circle" of angular distance C0 (in degrees) from the
  !     center.
  !
  !  2. Method :
  !
  !     Map Projections -- A Working Manual, John P. Snyder
  !     U.S. Geological Survey professional paper; 1395
  !     Chapter 21. Stereographic projection
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       LAM0    Real   I   Longitude of center of projection.
  !       PHI0    Real   I   Latitude of center of projection.
  !       C0      Real   I   Angular distance from center of projection
  !                          where the scale factor is one.
  !       LAM     Real   I   Longitude of input point.
  !       PHI     Real   I   Latitude of input point.
  !       X       Real   O   Cartesian x-coordinate of input point.
  !       Y       Real   O   Cartesian y-coordinate of input point.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3splx_0d_r4( LAM0, PHI0, C0, LAM, PHI, X, Y )
    !     Single precision point interface
    REAL(4), INTENT(IN) :: lam0, phi0, c0
    REAL(4), INTENT(IN) :: lam, phi
    REAL(4), INTENT(OUT):: x, y
 
    !     Local parameters
    REAL(8) :: k, k0, clam, slam, cphi0, cphi, sphi0, sphi
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPLX_0D_R4')
#endif
 
    clam  = cos((lam-lam0)*d2r)
    slam  = sin((lam-lam0)*d2r)
    cphi0 = cos(phi0*d2r)
    cphi  = cos(phi*d2r)
    sphi0 = sin(phi0*d2r)
    sphi  = sin(phi*d2r)
    k0    = cos(half*c0*d2r)**2
    k     = two*k0*rearth/(one+sphi0*sphi+cphi0*cphi*clam)
    x     = k*cphi*slam
    y     = k*(cphi0*sphi-sphi0*cphi*clam)
 
  END SUBROUTINE w3splx_0d_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3splx_0d_r8( LAM0, PHI0, C0, LAM, PHI, X, Y )
    !     Double precision point interface
    REAL(8), INTENT(IN) :: lam0, phi0, c0
    REAL(8), INTENT(IN) :: lam, phi
    REAL(8), INTENT(OUT):: x, y
 
    !     Local parameters
    REAL(8) :: k, k0, clam, slam, cphi0, cphi, sphi0, sphi
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPLX_0D_R8')
#endif
 
    clam  = cos((lam-lam0)*d2r)
    slam  = sin((lam-lam0)*d2r)
    cphi0 = cos(phi0*d2r)
    cphi  = cos(phi*d2r)
    sphi0 = sin(phi0*d2r)
    sphi  = sin(phi*d2r)
    k0    = cos(half*c0*d2r)**2
    k     = two*k0*rearth/(one+sphi0*sphi+cphi0*cphi*clam)
    x     = k*cphi*slam
    y     = k*(cphi0*sphi-sphi0*cphi*clam)
 
  END SUBROUTINE w3splx_0d_r8
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3splx_1d_r4( LAM0, PHI0, C0, LAM, PHI, X, Y )
    !     Single precision 1D array interface
    REAL(4), INTENT(IN) :: lam0, phi0, c0
    REAL(4), INTENT(IN) :: lam(:), phi(:)
    REAL(4), INTENT(OUT):: x(:), y(:)
 
    !     Local parameters
    INTEGER :: i
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPLX_1D_R4')
#endif
 
    DO i = lbound(lam,1),ubound(lam,1)
      CALL w3splx( lam0, phi0, c0, lam(i), phi(i), x(i), y(i) )
    ENDDO
 
  END SUBROUTINE w3splx_1d_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3splx_1d_r8( LAM0, PHI0, C0, LAM, PHI, X, Y )
    !     Double precision 1D array interface
    REAL(8), INTENT(IN) :: lam0, phi0, c0
    REAL(8), INTENT(IN) :: lam(:), phi(:)
    REAL(8), INTENT(OUT):: x(:), y(:)
 
    !     Local parameters
    INTEGER :: i
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPLX_1D_R8')
#endif
 
    DO i = lbound(lam,1),ubound(lam,1)
      CALL w3splx( lam0, phi0, c0, lam(i), phi(i), x(i), y(i) )
    ENDDO
 
  END SUBROUTINE w3splx_1d_r8
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3splx_2d_r4( LAM0, PHI0, C0, LAM, PHI, X, Y )
    !     Single precision 2D array interface
    REAL(4), INTENT(IN) :: lam0, phi0, c0
    REAL(4), INTENT(IN) :: lam(:,:), phi(:,:)
    REAL(4), INTENT(OUT):: x(:,:), y(:,:)
 
    !     Local parameters
    INTEGER :: i, j
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPLX_2D_R4')
#endif
 
    DO j = lbound(lam,2),ubound(lam,2)
      DO i = lbound(lam,1),ubound(lam,1)
        CALL w3splx( lam0, phi0, c0, lam(i,j), phi(i,j), x(i,j), y(i,j) )
      ENDDO
    ENDDO
 
  END SUBROUTINE w3splx_2d_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3splx_2d_r8( LAM0, PHI0, C0, LAM, PHI, X, Y )
    !     Double precision 2D array interface
    REAL(8), INTENT(IN) :: lam0, phi0, c0
    REAL(8), INTENT(IN) :: lam(:,:), phi(:,:)
    REAL(8), INTENT(OUT):: x(:,:), y(:,:)
 
    !     Local parameters
    INTEGER :: i, j
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPLX_2D_R8')
#endif
 
    DO j = lbound(lam,2),ubound(lam,2)
      DO i = lbound(lam,1),ubound(lam,1)
        CALL w3splx( lam0, phi0, c0, lam(i,j), phi(i,j), x(i,j), y(i,j) )
      ENDDO
    ENDDO
 
  END SUBROUTINE w3splx_2d_r8
  !/
  !/ End of W3SPLX ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3SPXL( LAM0, PHI0, X, Y, LAM, PHI )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute longitude and latitude coordinates from input Cartesian
  !     coordinates using stereographic projection with center at (LAM0,PHI0)
  !     and "standard circle" of angular distance C0 (in degrees) from the
  !     center.
  !
  !  2. Method :
  !
  !     Map Projections -- A Working Manual, John P. Snyder
  !     U.S. Geological Survey professional paper; 1395
  !     Chapter 21. Stereographic projection
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       LAM0    Real   I   Longitude of center of projection.
  !       PHI0    Real   I   Latitude of center of projection.
  !       C0      Real   I   Angular distance from center of projection
  !                          where the scale factor is one.
  !       X       Real   I   Cartesian x-coordinate of input point.
  !       Y       Real   I   Cartesian y-coordinate of input point.
  !       LAM     Real   O   Longitude of input point.
  !       PHI     Real   O   Latitude of input point.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3spxl_0d_r4( LAM0, PHI0, C0, X, Y, LAM, PHI )
    !     Single precision point interface
    REAL(4), INTENT(IN) :: lam0, phi0, c0
    REAL(4), INTENT(IN) :: x, y
    REAL(4), INTENT(OUT):: lam, phi
 
    !     Local parameters
    REAL(8) :: k0, rho, c, cosc, sinc, cphi0, sphi0
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPXL_0D_R4')
#endif
 
    k0    = cos(half*c0*d2r)**2
    rho   = sqrt(x*x+y*y)
    c     = two*atan2(rho,two*rearth*k0)
    cosc  = cos(c)
    sinc  = sin(c)
    cphi0 = cos(phi0*d2r)
    sphi0 = sin(phi0*d2r)
    phi   = asin(cosc*sphi0+y*sinc*cphi0/rho)*r2d
    lam   = lam0 + atan2(x*sinc,rho*cphi0*cosc-y*sphi0*sinc)*r2d
 
  END SUBROUTINE w3spxl_0d_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3spxl_0d_r8( LAM0, PHI0, C0, X, Y, LAM, PHI )
    !     Double precision point interface
    REAL(8), INTENT(IN) :: lam0, phi0, c0
    REAL(8), INTENT(IN) :: x, y
    REAL(8), INTENT(OUT):: lam, phi
 
    !     Local parameters
    REAL(8) :: k0, rho, c, cosc, sinc, cphi0, sphi0
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPXL_0D_R8')
#endif
 
    k0    = cos(half*c0*d2r)**2
    rho   = sqrt(x*x+y*y)
    c     = two*atan2(rho,two*rearth*k0)
    cosc  = cos(c)
    sinc  = sin(c)
    cphi0 = cos(phi0*d2r)
    sphi0 = sin(phi0*d2r)
    phi   = asin(cosc*sphi0+y*sinc*cphi0/rho)*r2d
    lam   = lam0 + atan2(x*sinc,rho*cphi0*cosc-y*sphi0*sinc)*r2d
 
  END SUBROUTINE w3spxl_0d_r8
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3spxl_1d_r4( LAM0, PHI0, C0, X, Y, LAM, PHI )
    !     Single precision 1D array interface
    REAL(4), INTENT(IN) :: lam0, phi0, c0
    REAL(4), INTENT(IN) :: x(:), y(:)
    REAL(4), INTENT(OUT):: lam(:), phi(:)
 
    !     Local parameters
    INTEGER :: i
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPXL_1D_R4')
#endif
 
    DO i = lbound(x,1),ubound(x,1)
      CALL w3spxl( lam0, phi0, c0, x(i), y(i), lam(i), phi(i) )
    ENDDO
 
  END SUBROUTINE w3spxl_1d_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3spxl_1d_r8( LAM0, PHI0, C0, X, Y, LAM, PHI )
    !     Double precision 1D array interface
    REAL(8), INTENT(IN) :: lam0, phi0, c0
    REAL(8), INTENT(IN) :: x(:), y(:)
    REAL(8), INTENT(OUT):: lam(:), phi(:)
 
    !     Local parameters
    INTEGER :: i
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPXL_1D_R8')
#endif
 
    DO i = lbound(x,1),ubound(x,1)
      CALL w3spxl( lam0, phi0, c0, x(i), y(i), lam(i), phi(i) )
    ENDDO
 
  END SUBROUTINE w3spxl_1d_r8
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3spxl_2d_r4( LAM0, PHI0, C0, X, Y, LAM, PHI )
    !     Single precision 2D array interface
    REAL(4), INTENT(IN) :: lam0, phi0, c0
    REAL(4), INTENT(IN) :: x(:,:), y(:,:)
    REAL(4), INTENT(OUT):: lam(:,:), phi(:,:)
 
    !     Local parameters
    INTEGER :: i, j
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPXL_2D_R4')
#endif
 
    DO j = lbound(x,2),ubound(x,2)
      DO i = lbound(x,1),ubound(x,1)
        CALL w3spxl( lam0, phi0, c0, x(i,j), y(i,j), lam(i,j), phi(i,j) )
      ENDDO
    ENDDO
 
  END SUBROUTINE w3spxl_2d_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3spxl_2d_r8( LAM0, PHI0, C0, X, Y, LAM, PHI )
    !     Double precision 2D array interface
    REAL(8), INTENT(IN) :: lam0, phi0, c0
    REAL(8), INTENT(IN) :: x(:,:), y(:,:)
    REAL(8), INTENT(OUT):: lam(:,:), phi(:,:)
 
    !     Local parameters
    INTEGER :: i, j
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SPXL_2D_R8')
#endif
 
    DO j = lbound(x,2),ubound(x,2)
      DO i = lbound(x,1),ubound(x,1)
        CALL w3spxl( lam0, phi0, c0, x(i,j), y(i,j), lam(i,j), phi(i,j) )
      ENDDO
    ENDDO
 
  END SUBROUTINE w3spxl_2d_r8
  !/
  !/ End of W3SPXL ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3TRLL( LAM0, PHI0, LAM1, PHI1, LAM, PHI )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute longitude and latitude for input coordinates in a
  !     coordinate system with the North Pole placed at a latitude
  !     PHI0 on a meridian LAM0 east of the central meridian.
  !
  !  2. Method :
  !
  !     Map Projections -- A Working Manual, John P. Snyder
  !     U.S. Geological Survey professional paper; 1395
  !     Chapter 5. Transformation of Map Graticules
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       LAM0    Real   I   Longitude of North Pole
  !       PHI0    Real   I   Latitude of North Pole
  !       LAM1    Real   I   Input Longitude
  !       PHI1    Real   I   Input Latitude
  !       LAM     Real   O   Transformed Longitude
  !       PHI     Real   O   Transformed Latitude
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3trll_0d_r4( LAM0, PHI0, LAM1, PHI1, LAM, PHI )
    !     Single precision point interface
    REAL(4), INTENT(IN) :: lam0, phi0
    REAL(4), INTENT(IN) :: lam1, phi1
    REAL(4), INTENT(OUT):: lam, phi
 
    !     Local parameters
    REAL(8) :: clam, slam, calp, salp, cphi, sphi
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3TRLL_0D_R4')
#endif
 
    clam  = cos((lam1-lam0)*d2r)
    slam  = sin((lam1-lam0)*d2r)
    calp  = cos(phi0*d2r)
    salp  = sin(phi0*d2r)
    cphi  = cos(phi1*d2r)
    sphi  = sin(phi1*d2r)
    lam   = lam0 + atan2(cphi*slam,salp*cphi*clam+calp*sphi)*r2d
    phi   = asin(salp*sphi-calp*cphi*clam)*r2d
 
  END SUBROUTINE w3trll_0d_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3trll_0d_r8( LAM0, PHI0, LAM1, PHI1, LAM, PHI )
    !     Double precision point interface
    REAL(8), INTENT(IN) :: lam0, phi0
    REAL(8), INTENT(IN) :: lam1, phi1
    REAL(8), INTENT(OUT):: lam, phi
 
    !     Local parameters
    REAL(8) :: clam, slam, calp, salp, cphi, sphi
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3TRLL_0D_R8')
#endif
 
    clam  = cos((lam1-lam0)*d2r)
    slam  = sin((lam1-lam0)*d2r)
    calp  = cos(phi0*d2r)
    salp  = sin(phi0*d2r)
    cphi  = cos(phi1*d2r)
    sphi  = sin(phi1*d2r)
    lam   = lam0 + atan2(cphi*slam,salp*cphi*clam+calp*sphi)*r2d
    phi   = asin(salp*sphi-calp*cphi*clam)*r2d
 
  END SUBROUTINE w3trll_0d_r8
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3trll_1d_r4( LAM0, PHI0, LAM1, PHI1, LAM, PHI )
    !     Single precision 1D array interface
    REAL(4), INTENT(IN) :: lam0, phi0
    REAL(4), INTENT(IN) :: lam1(:), phi1(:)
    REAL(4), INTENT(OUT):: lam(:), phi(:)
 
    !     Local parameters
    INTEGER :: i
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3TRLL_1D_R4')
#endif
 
    DO i = lbound(lam1,1),ubound(lam1,1)
      CALL w3trll( lam0, phi0, lam1(i), phi1(i), lam(i), phi(i) )
    ENDDO
 
  END SUBROUTINE w3trll_1d_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3trll_1d_r8( LAM0, PHI0, LAM1, PHI1, LAM, PHI )
    !     Double precision 1D array interface
    REAL(8), INTENT(IN) :: lam0, phi0
    REAL(8), INTENT(IN) :: lam1(:), phi1(:)
    REAL(8), INTENT(OUT):: lam(:), phi(:)
 
    !     Local parameters
    INTEGER :: i
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3TRLL_1D_R8')
#endif
 
    DO i = lbound(lam1,1),ubound(lam1,1)
      CALL w3trll( lam0, phi0, lam1(i), phi1(i), lam(i), phi(i) )
    ENDDO
 
  END SUBROUTINE w3trll_1d_r8
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3trll_2d_r4( LAM0, PHI0, LAM1, PHI1, LAM, PHI )
    !     Single precision 2D array interface
    REAL(4), INTENT(IN) :: lam0, phi0
    REAL(4), INTENT(IN) :: lam1(:,:), phi1(:,:)
    REAL(4), INTENT(OUT):: lam(:,:), phi(:,:)
 
    !     Local parameters
    INTEGER :: i, j
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3TRLL_2D_R4')
#endif
 
    DO j = lbound(lam1,2),ubound(lam1,2)
      DO i = lbound(lam1,1),ubound(lam1,1)
        CALL w3trll( lam0, phi0, lam1(i,j), phi1(i,j), lam(i,j), phi(i,j) )
      ENDDO
    ENDDO
 
  END SUBROUTINE w3trll_2d_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3trll_2d_r8( LAM0, PHI0, LAM1, PHI1, LAM, PHI )
    !     Double precision 2D array interface
    REAL(8), INTENT(IN) :: lam0, phi0
    REAL(8), INTENT(IN) :: lam1(:,:), phi1(:,:)
    REAL(8), INTENT(OUT):: lam(:,:), phi(:,:)
 
    !     Local parameters
    INTEGER :: i, j
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3TRLL_2D_R8')
#endif
 
    DO j = lbound(lam1,2),ubound(lam1,2)
      DO i = lbound(lam1,1),ubound(lam1,1)
        CALL w3trll( lam0, phi0, lam1(i,j), phi1(i,j), lam(i,j), phi(i,j) )
      ENDDO
    ENDDO
 
  END SUBROUTINE w3trll_2d_r8
  !/
  !/ End of W3TRLL ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3LLAZ( LAM1, PHI1, LAM2, PHI2 ) RESULT(AZ)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute azimuth (Az) east of north which point (LAM2,PHI2) bears
  !     to point (LAM1,PHI1).
  !
  !  2. Method :
  !
  !     Map Projections -- A Working Manual, John P. Snyder
  !     U.S. Geological Survey professional paper; 1395
  !     Chapter 5. Transformation of Map Graticules
  !
  !  3. Parameters :
  !
  !     Return parameter
  !     ----------------------------------------------------------------
  !       AZ      Real   O   Azimuth in degrees east of north
  !     ----------------------------------------------------------------
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       LAM1    Real   I   Longitude for point 1
  !       PHI1    Real   I   Latitude for point 1
  !       LAM2    Real   I   Longitude for point 2
  !       PHI2    Real   I   Latitude for point 2
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3llaz_r4( LAM1, PHI1, LAM2, PHI2 ) RESULT(AZ)
    !     Single precision interface
    REAL(4)            :: az
    REAL(4), INTENT(IN):: lam1, phi1
    REAL(4), INTENT(IN):: lam2, phi2
 
    !     Local parameters
    REAL(8) :: clam, slam, cph1, sph1, cph2, sph2
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3LLAZ_R4')
#endif
 
    clam = cos((lam2-lam1)*d2r)
    slam = sin((lam2-lam1)*d2r)
    cph1 = cos(phi1*d2r)
    sph1 = sin(phi1*d2r)
    cph2 = cos(phi2*d2r)
    sph2 = sin(phi2*d2r)
    az   = atan2(cph2*slam,cph1*sph2-sph1*cph2*clam)*r2d
 
  END FUNCTION w3llaz_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3llaz_r8( LAM1, PHI1, LAM2, PHI2 ) RESULT(AZ)
    !     Double precision interface
    REAL(8)            :: az
    REAL(8), INTENT(IN):: lam1, phi1
    REAL(8), INTENT(IN):: lam2, phi2
 
    !     Local parameters
    REAL(8) :: clam, slam, cph1, sph1, cph2, sph2
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3LLAZ_R8')
#endif
 
    clam = cos((lam2-lam1)*d2r)
    slam = sin((lam2-lam1)*d2r)
    cph1 = cos(phi1*d2r)
    sph1 = sin(phi1*d2r)
    cph2 = cos(phi2*d2r)
    sph2 = sin(phi2*d2r)
    az   = atan2(cph2*slam,cph1*sph2-sph1*cph2*clam)*r2d
 
  END FUNCTION w3llaz_r8
  !/
  !/ End of W3LLAZ ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3FDWT( N, ND, M, Z, X, C )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Compute finite-difference weights on arbitrarily spaced
  !     1-D node sets.
  !
  !  2. Method :
  !
  !     Fornberg, B., Calculation of weights in finite difference formulas,
  !       SIAM Rev. 40:685-691, 1998.
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       N       Int.   I   One less than total number of grid points;
  !                          n must not exceed the parameter nd below.
  !       ND      Int.   I   Dimension of X- and C-arrays in calling program
  !                          X(0:ND) and C(0:ND,0:M), respectively.
  !       M       Int.   I   Highest derivative for which weights are sought.
  !       Z       Real   I   Location where approximations are to be accurate.
  !       X       R.A.   I   Grid point locations, found in X(0:N)
  !       C       R.A.   O   Weights at grid locations X(0:N) for derivatives
  !                          of order 0:M, found in C(0:N,0:M)
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3fdwt_r4 ( N, ND, M, Z, X, C )
    !     Single precision interface
    INTEGER, INTENT(IN)  :: n, nd, m
    REAL(4), INTENT(IN)  :: z
    REAL(4), INTENT(IN)  :: x(0:nd)
    REAL(4), INTENT(OUT) :: c(0:nd,0:m)
 
    !     Local parameters
    INTEGER :: i, j, k, mn
    REAL(8) :: c1, c2, c3, c4, c5
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3FDWT_R4')
#endif
 
    c1 = one
    c4 = x(0)-z
    c(:,:) = zero
    c(0,0) = one
    iloop: DO i = 1,n
      mn = min(i,m)
      c2 = one
      c5 = c4
      c4 = x(i)-z
      jloop: DO j = 0,i-1
        c3 = x(i)-x(j)
        c2 = c2*c3
        IF ( j.EQ.i-1 ) THEN
          DO k = mn,1,-1
            c(i,k) = c1*(k*c(i-1,k-1)-c5*c(i-1,k))/c2
          END DO
          c(i,0) = -c1*c5*c(i-1,0)/c2
        END IF
        DO k = mn,1,-1
          c(j,k) = (c4*c(j,k)-k*c(j,k-1))/c3
        END DO
        c(j,0) = c4*c(j,0)/c3
      END DO jloop
      c1 = c2
    END DO iloop
 
  END SUBROUTINE w3fdwt_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3fdwt_r8 ( N, ND, M, Z, X, C )
    !     Double precision interface
    INTEGER, INTENT(IN)  :: n, nd, m
    REAL(8), INTENT(IN)  :: z
    REAL(8), INTENT(IN)  :: x(0:nd)
    REAL(8), INTENT(OUT) :: c(0:nd,0:m)
 
    !     Local parameters
    INTEGER :: i, j, k, mn
    REAL(8) :: c1, c2, c3, c4, c5
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3FDWT_R4')
#endif
 
    c1 = one
    c4 = x(0)-z
    c(:,:) = zero
    c(0,0) = one
    iloop: DO i = 1,n
      mn = min(i,m)
      c2 = one
      c5 = c4
      c4 = x(i)-z
      jloop: DO j = 0,i-1
        c3 = x(i)-x(j)
        c2 = c2*c3
        IF ( j.EQ.i-1 ) THEN
          DO k = mn,1,-1
            c(i,k) = c1*(k*c(i-1,k-1)-c5*c(i-1,k))/c2
          END DO
          c(i,0) = -c1*c5*c(i-1,0)/c2
        END IF
        DO k = mn,1,-1
          c(j,k) = (c4*c(j,k)-k*c(j,k-1))/c3
        END DO
        c(j,0) = c4*c(j,0)/c3
      END DO jloop
      c1 = c2
    END DO iloop
 
  END SUBROUTINE w3fdwt_r8
  !/
  !/ End of W3FDWT ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3NNSC( NLVL ) RESULT(NNS)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Create nearest-neighbor (NNBR) search object.
  !
  !  2. Method :
  !
  !     Notation
  !     ( L,  N):  L = NNBR level;  N = NNBR sequential index
  !     {DI, DJ}:  DI = I-index delta;  DJ = J-index delta
  !
  !     ---------------------------------------------------
  !     | ( 2,21) | ( 2,20) | ( 2,19) | ( 2,18) | ( 2,17) |
  !     | {-2,+2} | {-1,+2} | { 0,+2} | {+1,+2} | {+2,+2} |
  !     ---------------------------------------------------
  !     | ( 2,22) | ( 1, 7) | ( 1, 6) | ( 1, 5) | ( 2,16) |
  !     | {-2,+1} | {-1,+1} | { 0,+1} | {+1,+1} | {+2,+1} |
  !     ---------------------------------------------------
  !     | ( 2,23) | ( 1, 8) | ( 0, 0) | ( 1, 4) | ( 2,15) |
  !     | {-2, 0} | {-1, 0} | { 0, 0} | {+1, 0} | {+2, 0} |
  !     ---------------------------------------------------
  !     | ( 2,24) | ( 1, 1) | ( 1, 2) | ( 1, 3) | ( 2,14) |
  !     | {-2,-1} | {-1,-1} | { 0,-1} | {+1,-1} | {+2,-1} |
  !     ---------------------------------------------------
  !     | ( 2, 9) | ( 2,10) | ( 2,11) | ( 2,12) | ( 2,13) |
  !     | {-2,-2} | {-1,-2} | { 0,-2} | {+1,-2} | {+2,-2} |
  !     ---------------------------------------------------
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3nnsc( NLVL ) RESULT(NNS)
    TYPE(t_nns), POINTER :: nns
    INTEGER, INTENT(IN)  :: nlvl
 
    !     Local parameters
    INTEGER :: i, j, l, n
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3NNSC')
#endif
    !
    !-----allocate object
    ALLOCATE(nns)
 
    !-----initialize sizes
    nns%NLVL = nlvl
    nns%NNBR = (2*nlvl+1)**2
 
    !-----allocate arrays
    ALLOCATE(nns%N1(0:nns%NLVL))
    ALLOCATE(nns%N2(0:nns%NLVL))
    ALLOCATE(nns%DI(0:nns%NNBR-1))
    ALLOCATE(nns%DJ(0:nns%NNBR-1))
 
    !-----compute index deltas for nearest-neighbor searches
    n = 0
    !-----central point
    l = 0
    nns%N1(l) = 0;  nns%N2(l) = (2*l+1)**2-1;
    nns%DI(n) = 0;  nns%DJ(n) = 0;
    !-----loop over levels
    DO l=1,nns%NLVL
      !---------nnbr loop bounds
      nns%N1(l) = (2*l-1)**2;  nns%N2(l) = (2*l+1)**2-1;
      !---------bottom-layer
      j = -l
      DO i=-l,l-1
        n = n + 1
        nns%DI(n) = i;  nns%DJ(n) = j;
      END DO
      !---------right-layer
      i =  l
      DO j=-l,l-1
        n = n + 1
        nns%DI(n) = i;  nns%DJ(n) = j;
      END DO
      !---------top-layer
      j =  l
      DO i=l,-l+1,-1
        n = n + 1
        nns%DI(n) = i;  nns%DJ(n) = j;
      END DO
      !---------left-layer
      i = -l
      DO j=l,-l+1,-1
        n = n + 1
        nns%DI(n) = i;  nns%DJ(n) = j;
      END DO
    END DO !loop over levels
 
  END FUNCTION w3nnsc
  !/
  !/ End of W3NNSC ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3NNSD( NNS )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Destroy nearest-neighbor (NNBR) search object.
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3nnsd( NNS )
    TYPE(t_nns), POINTER :: nns
 
    !     Local parameters
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3NNSD')
#endif
    !
    IF ( ASSOCIATED(nns) ) THEN
      nns%NLVL = 0
      nns%NNBR = 0
      IF ( ASSOCIATED(nns%N1) ) THEN
        DEALLOCATE(nns%N1);  NULLIFY(nns%N1);
      END IF
      IF ( ASSOCIATED(nns%N2) ) THEN
        DEALLOCATE(nns%N2);  NULLIFY(nns%N2);
      END IF
      IF ( ASSOCIATED(nns%DI) ) THEN
        DEALLOCATE(nns%DI);  NULLIFY(nns%DI);
      END IF
      IF ( ASSOCIATED(nns%DJ) ) THEN
        DEALLOCATE(nns%DJ);  NULLIFY(nns%DJ);
      END IF
      DEALLOCATE(nns)
      NULLIFY(nns)
    END IF
 
  END SUBROUTINE w3nnsd
  !/
  !/ End of W3NNSD ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3NNSP( NNS, IUNIT )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Print nearest-neighbor (NNBR) search object to IUNIT.
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !       NNBR    Type   I   Nearest-neighbor search object.
  !       IUNIT   Int.   I   OPTIONAL unit for output. Default is stdout.
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3nnsp(NNS, IUNIT)
    TYPE(t_nns), INTENT(IN) :: nns
    INTEGER, OPTIONAL, INTENT(IN) :: iunit
 
    !     Local parameters
    INTEGER :: ndst, l, n
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3NNSP')
#endif
    !
    IF ( PRESENT(iunit) ) THEN
      ndst = iunit
    ELSE
      ndst = 6
    END IF
    !
    WRITE(ndst,'(A,2I6)') 'nlvl,nnbr:',nns%NLVL,nns%NNBR
    DO l=0,nns%NLVL
      DO n=nns%N1(l),nns%N2(l)
        WRITE(ndst,'(A,4I6)') 'l,n,di,dj:',l,n,nns%DI(n),nns%DJ(n)
      END DO
    END DO
 
  END SUBROUTINE w3nnsp
  !/
  !/ End of W3NNSP ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3SORT( N, I, J, D )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Sort input arrays in increasing order according to input array D.
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3sort_r4( N, I, J, D )
    !     Single precision interface.
    INTEGER, INTENT(IN)    :: n
    INTEGER, INTENT(INOUT) :: i(n)
    INTEGER, INTENT(INOUT) :: j(n)
    REAL(4), INTENT(INOUT) :: d(n)
 
    !     Local parameters
    INTEGER :: k, l, im, jm
    REAL(4) :: dm
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SORT_R4')
#endif
 
    DO k=1, n-1
      DO l=k+1, n
        IF ( d(l) .LT. d(k) ) THEN
          im = i(k);  jm = j(k);  dm = d(k);
          i(k) = i(l);  j(k) = j(l);  d(k) = d(l);
          i(l) = im;  j(l) = jm;  d(l) = dm;
        END IF
      END DO !L
    END DO !K
 
  END SUBROUTINE w3sort_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3sort_r8( N, I, J, D )
    !     Double precision interface.
    INTEGER, INTENT(IN)    :: n
    INTEGER, INTENT(INOUT) :: i(n)
    INTEGER, INTENT(INOUT) :: j(n)
    REAL(8), INTENT(INOUT) :: d(n)
 
    !     Local parameters
    INTEGER :: k, l, im, jm
    REAL(8) :: dm
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3SORT_R8')
#endif
 
    DO k=1, n-1
      DO l=k+1, n
        IF ( d(l) .LT. d(k) ) THEN
          im = i(k);  jm = j(k);  dm = d(k);
          i(k) = i(l);  j(k) = j(l);  d(k) = d(l);
          i(l) = im;  j(l) = jm;  d(l) = dm;
        END IF
      END DO !L
    END DO !K
 
  END SUBROUTINE w3sort_r8
  !/
  !/ End of W3SORT ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    SUBROUTINE W3ISRT( II, JJ, DD, N, I, J, D )
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Insert DD data into D at location where DD < D(K).
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3isrt_r4( II, JJ, DD, N, I, J, D )
    !     Single precision interface
    INTEGER, INTENT(IN)    :: ii
    INTEGER, INTENT(IN)    :: jj
    REAL(4), INTENT(IN)    :: dd
    INTEGER, INTENT(IN)    :: n
    INTEGER, INTENT(INOUT) :: i(n)
    INTEGER, INTENT(INOUT) :: j(n)
    REAL(4), INTENT(INOUT) :: d(n)
 
    !     Local parameters
    INTEGER :: k, l
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3ISRT_R4')
#endif
 
    k_loop: DO k=1,n
      IF ( dd .LT. d(k) ) THEN
        !-------------right-shift list (>= k)
        DO l=n,k+1,-1
          i(l) = i(l-1);  j(l) = j(l-1);  d(l) = d(l-1);
        END DO !L
        !-------------insert point into list at k
        i(k) = ii;  j(k) = jj;  d(k) = dd;
        EXIT k_loop
      END IF !dd.lt.d(k)
    END DO k_loop
 
  END SUBROUTINE w3isrt_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE w3isrt_r8( II, JJ, DD, N, I, J, D )
    !     Double precision interface
    INTEGER, INTENT(IN)    :: ii
    INTEGER, INTENT(IN)    :: jj
    REAL(8), INTENT(IN)    :: dd
    INTEGER, INTENT(IN)    :: n
    INTEGER, INTENT(INOUT) :: i(n)
    INTEGER, INTENT(INOUT) :: j(n)
    REAL(8), INTENT(INOUT) :: d(n)
 
    !     Local parameters
    INTEGER :: k, l
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3ISRT_R8')
#endif
 
    k_loop: DO k=1,n
      IF ( dd .LT. d(k) ) THEN
        !-------------right-shift list (>= k)
        DO l=n,k+1,-1
          i(l) = i(l-1);  j(l) = j(l-1);  d(l) = d(l-1);
        END DO !L
        !-------------insert point into list at k
        i(k) = ii;  j(k) = jj;  d(k) = dd;
        EXIT k_loop
      END IF !dd.lt.d(k)
    END DO k_loop
 
  END SUBROUTINE w3isrt_r8
  !/
  !/ End of W3ISRT ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ =================================================================== /
  !/
  !/    FUNCTION W3INAN( X ) RESULT(INAN)
  !/
  !/ =================================================================== /
  !/
  !  1. Purpose :
  !
  !     Return TRUE if input is infinite or NaN (not a number).
  !
  !  2. Method :
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !     See module documentation.
  !
  !  5. Called by :
  !
  !  6. Error messages :
  !
  !  7. Remarks :
  !
  !  8. Structure :
  !
  !  9. Switches :
  !
  !     !/S    Enable subroutine tracing.
  !
  ! 10. Source code :
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3inan_r4( X ) RESULT(INAN)
    !     Single precision interface
    LOGICAL             :: inan
    REAL(4), INTENT(IN) :: x
 
    !     Local parameters
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3INAN_R4')
#endif
 
    !-----return true if X is NaN or +Inf or -Inf
    inan = .NOT. ( x .GE. -huge(x) .AND. x .LE. huge(x) )
 
  END FUNCTION w3inan_r4
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION w3inan_r8( X ) RESULT(INAN)
    !     Double precision interface
    LOGICAL             :: inan
    REAL(8), INTENT(IN) :: x
 
    !     Local parameters
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3INAN_R8')
#endif
 
    !-----return true if X is NaN or +Inf or -Inf
    inan = .NOT. ( x .GE. -huge(x) .AND. x .LE. huge(x) )
 
  END FUNCTION w3inan_r8
  !/
  !/ End of W3INAN ===================================================== /
  !/
 
 
 
 
 
 
 
 
  !/
  !/ Internal Support Routines ========================================= /
  !/
  !/
  !/ ------------------------------------------------------------------- /
  !/
  FUNCTION gsu_create( IJG, LLG, ICLO, LB, UB, XG4, YG4, XG8, YG8, &
       BBOX_ONLY, NCB, NNP, DEBUG ) RESULT(GSU)
    !     *** INTERNAL SUBROUTINE ***
    TYPE(t_gsu)         :: gsu
    LOGICAL, INTENT(IN) :: ijg
    LOGICAL, INTENT(IN) :: llg
    INTEGER, INTENT(IN) :: iclo
    INTEGER, INTENT(IN) :: lb(2)
    INTEGER, INTENT(IN) :: ub(2)
    REAL(4), TARGET, OPTIONAL     :: xg4(lb(1):ub(1),lb(2):ub(2))
    REAL(4), TARGET, OPTIONAL     :: yg4(lb(1):ub(1),lb(2):ub(2))
    REAL(8), TARGET, OPTIONAL     :: xg8(lb(1):ub(1),lb(2):ub(2))
    REAL(8), TARGET, OPTIONAL     :: yg8(lb(1):ub(1),lb(2):ub(2))
    LOGICAL, INTENT(IN), OPTIONAL :: bbox_only
    INTEGER, INTENT(IN), OPTIONAL :: ncb
    INTEGER, INTENT(IN), OPTIONAL :: nnp
    LOGICAL, INTENT(IN), OPTIONAL :: debug
 
    !     Local parameters
    TYPE(class_gsu), POINTER :: ptr
    LOGICAL :: type_r4, type_r8
    LOGICAL :: ldbg, lbbox, lbc, lpl, lnpl, lspl
    INTEGER :: lbx, lby, ubx, uby, nx, ny
    INTEGER :: lxc, lyc, uxc, uyc
    INTEGER :: i, j, k, l, n, ic(4), jc(4), ib, jb
    INTEGER :: ns, ib1(2), ib2(2), jb1(2), jb2(2), ibc(4), jbc(4)
    INTEGER :: istep, istat
    REAL(8) :: xc(4), yc(4)
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'W3GSUC')
#endif
    ! -------------------------------------------------------------------- /
    ! 1.  Test input
    !
    type_r4 = PRESENT(xg4).AND.PRESENT(yg4)
    type_r8 = PRESENT(xg8).AND.PRESENT(yg8)
    IF ( .NOT.type_r4.AND..NOT.type_r8 ) THEN
      WRITE(0,'(/1A,1A,1I2/)') 'W3GSUC ERROR -- ', &
           'no input grid coordinates specified'
      CALL extcde (1)
    END IF
 
    IF (ijg) THEN
      lbx = lb(1)
      lby = lb(2)
      ubx = ub(1)
      uby = ub(2)
    ELSE
      lbx = lb(2)
      lby = lb(1)
      ubx = ub(2)
      uby = ub(1)
    END IF
    nx = ubx - lbx + 1
    ny = uby - lby + 1
 
    SELECT CASE ( iclo )
    CASE ( iclo_none, iclo_grdi, iclo_grdj, iclo_trdl, iclo_trpl )
      CONTINUE
    CASE DEFAULT
      WRITE(0,'(/1A,1A,1I2/)') 'W3GSUC ERROR -- ', &
           'unsupported ICLO: ',iclo
      CALL extcde (1)
    END SELECT
 
    IF ( iclo.EQ.iclo_trpl .AND. mod(nx,2).NE.0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', &
           'tripole grid closure requires NX=UBX-LBX+1 be even'
      CALL extcde (1)
    END IF
 
    IF ( PRESENT(bbox_only) ) THEN
      lbbox = bbox_only
    ELSE
      lbbox = .false.
    END IF
 
    IF ( PRESENT(ncb) ) THEN
      IF ( ncb .LE. 0 ) THEN
        WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', &
             'NCB must be greater than zero'
        CALL extcde (1)
      END IF
    END IF
    !
    IF ( PRESENT(debug) ) THEN
      ldbg = debug
    ELSE
      ldbg = .false.
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Allocate object and set grid related data and pointers
    !
    ALLOCATE(ptr, stat=istat)
    IF ( istat .NE. 0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', &
           'gsu object allocation failed'
      CALL extcde (istat)
    END IF
    ptr%IJG = ijg
    ptr%LLG = llg
    ptr%ICLO = iclo
    ptr%LBX = lbx
    ptr%LBY = lby
    ptr%UBX = ubx
    ptr%UBY = uby
    ptr%NX = nx
    ptr%NY = ny
    IF (type_r4) THEN
      ptr%XG4 => xg4
      ptr%YG4 => yg4
      ptr%GKIND = 4
    ELSE
      ptr%XG8 => xg8
      ptr%YG8 => yg8
      ptr%GKIND = 8
    END IF
    NULLIFY( ptr%NNP )
    NULLIFY( ptr%B )
    NULLIFY( ptr%NNB )
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Create nearest-neighbor point search object
    !
    IF ( .NOT.lbbox ) THEN
      IF ( PRESENT(nnp) ) THEN
        ptr%NNP => w3nnsc(nnp)
      ELSE
        ptr%NNP => w3nnsc(nnp_default)
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 4.  Construct bucket search "object"
    !
    !-----number of cells
    lxc = lbx;  lyc = lby;
    SELECT CASE ( iclo )
    CASE ( iclo_none )
      uxc = ubx-1;  uyc = uby-1;
    CASE ( iclo_grdi )
      uxc = ubx;    uyc = uby-1;
    CASE ( iclo_grdj )
      uxc = ubx-1;  uyc = uby;
    CASE ( iclo_trdl )
      uxc = ubx;    uyc = uby;
    CASE ( iclo_trpl )
      uxc = ubx;    uyc = uby;
    END SELECT
    !
    !-----initialize longitudinal periodicity flag (LCLO)
    IF ( llg .AND. iclo.NE.iclo_none ) THEN
      ptr%LCLO = .true.
    ELSE
      ptr%LCLO = .false.
    END IF
    !
    !-----check existence of longitudinal branch cut
    !-----check if source grid includes poles
    IF ( ldbg ) THEN
      WRITE(*,'(/A)') 'W3GSUC - check source grid'
    END IF
    lnpl = .false.
    lspl = .false.
    DO i=lxc,uxc
      DO j=lyc,uyc
        !-------------create list of cell vertices
        ic(1) = i  ;  jc(1) = j  ;
        ic(2) = i+1;  jc(2) = j  ;
        ic(3) = i+1;  jc(3) = j+1;
        ic(4) = i  ;  jc(4) = j+1;
        DO l=1,4
          !-----------------apply index closure
          IF ( mod(iclo,2).EQ.0 ) &
               ic(l) = lbx + mod(nx - 1 + mod(ic(l) - lbx + 1, nx), nx)
          IF ( mod(iclo,3).EQ.0 ) &
               jc(l) = lby + mod(ny - 1 + mod(jc(l) - lby + 1, ny), ny)
          IF ( iclo.EQ.iclo_trpl .AND. jc(l).GT.uby ) THEN
            ic(l) = ubx + lbx - ic(l)
            jc(l) = 2*uby - jc(l) + 1
          END IF
          !-----------------copy cell vertex coordinates into local variables
          IF ( ijg ) THEN
            IF (type_r4) THEN
              xc(l) = xg4(ic(l),jc(l))
              yc(l) = yg4(ic(l),jc(l))
            ELSE
              xc(l) = xg8(ic(l),jc(l))
              yc(l) = yg8(ic(l),jc(l))
            END IF
          ELSE
            IF (type_r4) THEN
              xc(l) = xg4(jc(l),ic(l))
              yc(l) = yg4(jc(l),ic(l))
            ELSE
              xc(l) = xg8(jc(l),ic(l))
              yc(l) = yg8(jc(l),ic(l))
            END IF
          END IF
        END DO !L
        !-------------check if cell includes a pole or branch cut
        lpl = .false.
        lbc = .false.
        IF ( llg ) THEN
          !-----------------count longitudinal branch cut crossings
          n = 0
          DO l=1,4
            k = mod(l,4)+1
            IF ( abs(xc(k)-xc(l)) .GT. d180 ) n = n + 1
          END DO
          !-----------------multiple longitudinal branch cut crossing => cell includes branch cut
          lbc = n.GT.1
          IF ( lbc .AND. ldbg ) &
               WRITE(*,'(A,8I6)') &
               'W3GSUC -- cell includes branch cut:',ic(:),jc(:)
          !-----------------single longitudinal branch cut crossing
          !                 or single vertex at 90 degrees => cell includes pole
          lpl = n.EQ.1 .OR. count(abs(yc).EQ.d90).EQ.1
          IF ( lpl.AND.minval(yc).GT.zero ) THEN
            IF ( ldbg ) &
                 WRITE(*,'(A,8I6)') &
                 'W3GSUC -- cell includes N-pole:',ic(:),jc(:)
            lnpl = .true.
          END IF
          IF ( lpl.AND.maxval(yc).LT.zero ) THEN
            IF ( ldbg ) &
                 WRITE(*,'(A,8I6)') &
                 'W3GSUC -- cell includes S-pole:',ic(:),jc(:)
            lspl = .true.
          END IF
          !-----------------longitudinal branch cut crossing => longitudinal closure
          IF ( n.GT.0 ) ptr%LCLO = .true.
        END IF !LLG
      END DO !J
    END DO !I
    !
    !-----compute domain for search buckets
    !     if longitudinal periodicity, then force domain in x to [0:360]
    !     if grid includes north pole, then set ymax =  90 degrees
    !     if grid includes south pole, then set ymin = -90 degrees
    IF (type_r4) THEN
      ptr%XMIN = minval(xg4);  ptr%XMAX = maxval(xg4);
      ptr%YMIN = minval(yg4);  ptr%YMAX = maxval(yg4);
    ELSE
      ptr%XMIN = minval(xg8);  ptr%XMAX = maxval(xg8);
      ptr%YMIN = minval(yg8);  ptr%YMAX = maxval(yg8);
    END IF
    IF ( ptr%LCLO ) THEN
      ptr%XMIN =  zero;  ptr%XMAX = d360;
    END IF
    IF ( lspl ) ptr%YMIN = -d90
    IF ( lnpl ) ptr%YMAX =  d90
    ptr%L360 = ptr%XMIN.GE.zero
    !
    !-----if bbox only, then set pointer and return
    IF ( lbbox ) THEN
      gsu%PTR => ptr
      RETURN
    END IF
    !
    !-----compute number of search buckets and bucket size
    IF ( PRESENT(ncb) ) THEN
      ptr%NBX = max(1,nx/ncb)
      ptr%NBY = max(1,ny/ncb)
    ELSE
      ptr%NBX = max(1,nx/ncb_default)
      ptr%NBY = max(1,ny/ncb_default)
    END IF
    ptr%DXB = (ptr%XMAX-ptr%XMIN)/real(ptr%NBX)
    ptr%DYB = (ptr%YMAX-ptr%YMIN)/real(ptr%NBY)
    !
    !-----print debug info
    IF ( ldbg ) THEN
      WRITE(*,'(/A,1I2,1L2,1I2)') 'W3GSUC - ICLO,LCLO,GKIND: ', &
           ptr%ICLO,ptr%LCLO,ptr%GKIND
      WRITE(*,'(A,4E24.16)') 'W3GSUC - grid search domain:', &
           ptr%XMIN,ptr%YMIN,ptr%XMAX,ptr%YMAX
      WRITE(*,'(A,2I6)') 'W3GSUC - number of search buckets:', &
           ptr%NBX,ptr%NBY
      WRITE(*,'(A,2E24.16)') 'W3GSUC - search bucket size:', &
           ptr%DXB,ptr%DYB
    END IF
    !
    !-----allocate array of search buckets
    ALLOCATE(ptr%B(ptr%NBY,ptr%NBX),stat=istat)
    IF ( istat .NE. 0 ) THEN
      WRITE(0,'(/1A,1A/)') 'W3GSUC ERROR -- ', &
           'search bucket array allocation failed'
      CALL extcde (istat)
    END IF
    !
    !-----BEGIN ISTEP_LOOP
    !     first step: compute number of cells in each bucket
    !     second step: allocate buckets and assign cells to buckets
    istep_loop: DO istep=1,2
      !
      !-----allocate search bucket cell lists
      IF ( istep .EQ. 2 ) THEN
        DO ib=1,ptr%NBX
          DO jb=1,ptr%NBY
            NULLIFY(ptr%B(jb,ib)%I)
            NULLIFY(ptr%B(jb,ib)%J)
            IF ( ptr%B(jb,ib)%N .GT. 0 ) THEN
              ALLOCATE(ptr%B(jb,ib)%I(ptr%B(jb,ib)%N),stat=istat)
              IF ( istat .NE. 0 ) THEN
                WRITE(0,'(/1A,2A,3I6/)') 'W3GSUC ERROR -- ', &
                     'search bucket cell-i list allocation failed -- ', &
                     'bucket: ',ib,jb,n
                CALL extcde (istat)
              END IF
              ALLOCATE(ptr%B(jb,ib)%J(ptr%B(jb,ib)%N),stat=istat)
              IF ( istat .NE. 0 ) THEN
                WRITE(0,'(/1A,2A,3I6/)') 'W3GSUC ERROR -- ', &
                     'search bucket cell-j list allocation failed -- ', &
                     'bucket: ',ib,jb,n
                CALL extcde (istat)
              END IF
            END IF
          END DO
        END DO
      END IF !ISTEP.EQ.2
      !
      !-----build search bucket cell lists
      ptr%B(:,:)%N = 0
      DO i=lxc,uxc
        DO j=lyc,uyc
          IF ( iclo.EQ.iclo_trpl ) THEN
            IF ( j.EQ.uyc .AND. i.GT.lbx+nx/2 ) cycle
          ENDIF
          !-------------create list of cell vertices
          ic(1) = i  ;  jc(1) = j  ;
          ic(2) = i+1;  jc(2) = j  ;
          ic(3) = i+1;  jc(3) = j+1;
          ic(4) = i  ;  jc(4) = j+1;
          DO l=1,4
            !-----------------apply index closure
            IF ( mod(iclo,2).EQ.0 ) &
                 ic(l) = lbx + mod(nx - 1 + mod(ic(l) - lbx + 1, nx), nx)
            IF ( mod(iclo,3).EQ.0 ) &
                 jc(l) = lby + mod(ny - 1 + mod(jc(l) - lby + 1, ny), ny)
            IF ( iclo.EQ.iclo_trpl .AND. jc(l).GT.uby ) THEN
              ic(l) = ubx + lbx - ic(l)
              jc(l) = 2*uby - jc(l) + 1
            END IF
            !-----------------copy cell vertex coordinates into local variables
            IF ( ijg ) THEN
              IF (type_r4) THEN
                xc(l) = xg4(ic(l),jc(l))
                yc(l) = yg4(ic(l),jc(l))
              ELSE
                xc(l) = xg8(ic(l),jc(l))
                yc(l) = yg8(ic(l),jc(l))
              END IF
            ELSE
              IF (type_r4) THEN
                xc(l) = xg4(jc(l),ic(l))
                yc(l) = yg4(jc(l),ic(l))
              ELSE
                xc(l) = xg8(jc(l),ic(l))
                yc(l) = yg8(jc(l),ic(l))
              END IF
            END IF
          END DO !L
          !-------------check if cell includes a pole or branch cut
          lpl = .false.
          lbc = .false.
          IF ( llg ) THEN
            !-----------------shift longitudes to appropriate range
            xc = mod(xc,d360)
            IF ( ptr%LCLO .OR. ptr%L360 ) THEN
              WHERE ( xc.LT.zero ) xc = xc + d360
            ELSE
              WHERE ( xc.GT.d180 ) xc = xc - d360
            END IF
            !-----------------count longitudinal branch cut crossings
            n = 0
            DO l=1,4
              k = mod(l,4)+1
              IF ( abs(xc(k)-xc(l)) .GT. d180 ) n = n + 1
            END DO
            !-----------------multiple longitudinal branch cut crossing => cell includes branch cut
            lbc = n.GT.1
            !-----------------single longitudinal branch cut crossing
            !                 or single vertex at 90 degrees => cell includes pole
            lpl = n.EQ.1 .OR. count(abs(yc).EQ.d90).EQ.1
          END IF !LLG
          !-------------set bucket id for each cell vertex
          DO l=1,4
            ibc(l) = int((xc(l)-ptr%XMIN)/ptr%DXB)+1
            IF ( .NOT.ptr%LCLO ) ibc(l) = min(ibc(l),ptr%NBX)
            jbc(l) = min(int((yc(l)-ptr%YMIN)/ptr%DYB)+1,ptr%NBY)
          END DO !L
          !-------------set bucket overlap bounds
          IF ( lpl ) THEN
            !---------------cell includes pole: overlap includes full longitudinal range
            ns = 1
            ib1(1) = 1
            ib2(1) = ptr%NBX
            IF ( minval(yc).GT.zero ) THEN
              jb1(1) = max(1,minval(jbc))
              jb2(1) = ptr%NBY
            END IF
            IF ( maxval(yc).LT.zero ) THEN
              jb1(1) = 1
              jb2(1) = min(ptr%NBY,maxval(jbc))
            END IF
            ib1(2) = 0
            ib2(2) = 0
            jb1(2) = 0
            jb2(2) = 0
          ELSE IF ( lbc ) THEN
            !---------------cell includes branch cut: split overlap into two sets
            ns = 2
            ib1(1) = ptr%NBX
            ib2(1) = ptr%NBX
            ib1(2) = 1
            ib2(2) = 1
            DO l=1,4
              IF ( ibc(l) .GT. ptr%NBX/2 ) THEN
                ib1(1) = min(ib1(1),ibc(l))
              ELSE
                ib2(2) = max(ib2(2),ibc(l))
              END IF
            END DO !L
            jb1(:) = max(1,minval(jbc))
            jb2(:) = min(ptr%NBY,maxval(jbc))
          ELSE
            !---------------default: overlap computed from min/max
            ns = 1
            ib1(1) = max(1,minval(ibc))
            ib2(1) = min(ptr%NBX,maxval(ibc))
            jb1(1) = max(1,minval(jbc))
            jb2(1) = min(ptr%NBY,maxval(jbc))
            ib1(2) = 0
            ib2(2) = 0
            jb1(2) = 0
            jb2(2) = 0
          END IF
          !-------------debug output
          IF ( ldbg .AND. istep.EQ.1 ) THEN
            WRITE(*,'(/A,2I6)')    'W3GSUC -- BUCKET SORT:',i,j
            WRITE(*,'(A,2L6,1I6)') 'W3GSUC -- LBC,LPL:',lbc,lpl
            WRITE(*,'(A,4I6)')     'W3GSUC -- IC:',ic(:)
            WRITE(*,'(A,4I6)')     'W3GSUC -- JC:',jc(:)
            WRITE(*,'(A,4E24.16)') 'W3GSUC -- XC:',xc(:)
            WRITE(*,'(A,4E24.16)') 'W3GSUC -- YC:',yc(:)
            WRITE(*,'(A,4I6)')     'W3GSUC -- IBC:',ibc(:)
            WRITE(*,'(A,4I6)')     'W3GSUC -- JBC:',jbc(:)
            WRITE(*,'(A,1I6)')     'W3GSUC -- NS:',ns
            WRITE(*,'(A,4I6)')     'W3GSUC -- IB1:',ib1(:)
            WRITE(*,'(A,4I6)')     'W3GSUC -- JB1:',jb1(:)
            WRITE(*,'(A,4I6)')     'W3GSUC -- IB2:',ib2(:)
            WRITE(*,'(A,4I6)')     'W3GSUC -- JB2:',jb2(:)
          END IF
          !-------------assign cell to buckets based on overlap
          DO k=1,ns
            DO ib=ib1(k),ib2(k)
              DO jb=jb1(k),jb2(k)
                ptr%B(jb,ib)%N = ptr%B(jb,ib)%N + 1
                IF ( istep .EQ. 2 ) THEN
                  ptr%B(jb,ib)%I(ptr%B(jb,ib)%N) = ic(1)
                  ptr%B(jb,ib)%J(ptr%B(jb,ib)%N) = jc(1)
                END IF
              END DO !JB
            END DO !IB
          END DO !K
        END DO !J
      END DO !I
      !
      !-----END ISTEP_LOOP
    END DO istep_loop
    !
    !-----create nearest-neighbor bucket search object
    ptr%NNB => w3nnsc(nint(half*max(ptr%NBX,ptr%NBY)))
    !
    !-----print debug info
    IF ( ldbg ) THEN
      WRITE(*,'(/A,3I6,4E24.16)') 'W3GSUC - search bucket list:'
      WRITE(*,'(3A6,4A14)') 'I','J','N','X1','Y1','X2','Y2'
      DO ib=1,ptr%NBX
        DO jb=1,ptr%NBY
          WRITE(*,'(3I6,4E24.16)') ib,jb,ptr%B(jb,ib)%N, &
               ptr%XMIN+(ib-1)*ptr%DXB,ptr%YMIN+(jb-1)*ptr%DYB, &
               ptr%XMIN+(ib-0)*ptr%DXB,ptr%YMIN+(jb-0)*ptr%DYB
        END DO
      END DO
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 5.  Set return parameter
    !
    gsu%PTR => ptr
 
  END FUNCTION gsu_create
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE getpqr( XT, YT, XS, YS, PR, QR, EPS, DEBUG )
    !     *** INTERNAL SUBROUTINE ***
    !     Compute source grid cell-relative coordinates (PR,QR) for target point (XT,YT)
    REAL(8), INTENT(IN)   :: xt
    REAL(8), INTENT(IN)   :: yt
    REAL(8), INTENT(IN)   :: xs(4)
    REAL(8), INTENT(IN)   :: ys(4)
    REAL(8), INTENT(OUT)  :: pr
    REAL(8), INTENT(OUT)  :: qr
    REAL(8), INTENT(IN),  OPTIONAL :: eps
    LOGICAL, INTENT(IN) , OPTIONAL :: debug
 
    !     Local parameters
    INTEGER, PARAMETER :: max_iter = 10
    REAL(8), PARAMETER :: converge = 1d-6
    REAL(8) :: leps
    LOGICAL :: ldbg
    INTEGER :: k, iter
    REAL(8) :: dxt, dx1, dx2, dx3, dxp, dyt, dy1, dy2, dy3, dyp
    REAL(8) :: mat1, mat2, mat3, mat4, delp, delq, det
#ifdef W3_S
    INTEGER, SAVE           :: ient = 0
    CALL strace (ient, 'GETPQR')
#endif
 
    IF ( PRESENT(eps) ) THEN
      IF ( eps .LT. zero ) THEN
        WRITE(0,'(/2A/)') 'GETPQR ERROR -- ', &
             'EPS parameter must be >= 0'
        CALL extcde (1)
      END IF
      leps = eps
    ELSE
      leps = eps_default
    END IF
    IF ( PRESENT(debug) ) THEN
      ldbg = debug
    ELSE
      ldbg = .false.
    END IF
    !
    !-----handle point coincident with a cell vertex
    DO k=1,4
      IF ( abs(xt-xs(k)).LE.leps .AND. abs(yt-ys(k)).LE.leps ) THEN
        SELECT CASE ( k )
        CASE ( 1 )
          pr = zero;  qr = zero;
        CASE ( 2 )
          pr =  one;  qr = zero;
        CASE ( 3 )
          pr =  one;  qr =  one;
        CASE ( 4 )
          pr = zero;  qr =  one;
        END SELECT
        IF ( ldbg ) &
             WRITE(*,'(A,I3,4E24.16)') 'GETPQR - COINCIDENT:', &
             k,abs(xt-xs(k)),abs(yt-ys(k)),pr,qr
        RETURN
      END IF
    END DO
    !
    !-----set iteration parameters and initial guess
    pr = half
    qr = half
    dyt = yt    - ys(1)
    dy1 = ys(2) - ys(1)
    dy2 = ys(4) - ys(1)
    dy3 = ys(3) - ys(2) - dy2
    dxt = xt    - xs(1)
    dx1 = xs(2) - xs(1)
    dx2 = xs(4) - xs(1)
    dx3 = xs(3) - xs(2) - dx2
 
    !-----iterate to find (PR,QR)
    iter_loop: DO iter=1,max_iter
      dyp  = dyt - dy1*pr - dy2*qr - dy3*pr*qr
      dxp  = dxt - dx1*pr - dx2*qr - dx3*pr*qr
      mat1 = dy1 + dy3*qr
      mat2 = dy2 + dy3*pr
      mat3 = dx1 + dx3*qr
      mat4 = dx2 + dx3*pr
      det  = mat1*mat4 - mat2*mat3
      delp = (dyp*mat4 - mat2*dxp)/det
      delq = (mat1*dxp - dyp*mat3)/det
      IF ( ldbg ) &
           WRITE(*,'(A,I3,4E24.16)') 'GETPQR - ITER:', &
           iter,pr,qr,delp,delq
      pr = pr + delp
      qr = qr + delq
      IF ( abs(delp) < converge .AND. &
           abs(delq) < converge ) EXIT iter_loop
    END DO iter_loop
 
    !-----if max iteration count exceeded, then exit with error
    IF ( iter .GT. max_iter ) THEN
      WRITE(0,'(/A)') &
           'GETPQR -- ERROR: exceeded max iteration count'
      WRITE(0,'(A,2E24.16)') 'GETPQR - DEST POINT COORDS: ',xt,yt
      DO k=1,4
        WRITE(0,'(A,I1,A,2E24.16)') &
             'GETPQR - SRC POINT ',k,': ',xs(k),ys(k)
      END DO
      WRITE(0,'(A,4E24.16)') &
           'GETPQR - CURRENT PR,QR,DELP,DELQ: ',pr,qr,delp,delq
      CALL extcde (1)
    END IF !(ITER.LE.MAX_ITER)
 
  END SUBROUTINE getpqr
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE getblc( GSU, I, J, PR, QR, LCMP, NS, LS, IS, JS, CS )
    !     *** INTERNAL SUBROUTINE ***
    !     Compute bilinear remap factors for a given point (P,Q)
    !     (I,J) = lower-left corner point of grid cell containing target point
    !     (PR,QR) = cell-relative coordinate of target point
    !     Double precision interface
    TYPE(t_gsu), INTENT(IN) :: gsu
    INTEGER, INTENT(IN)  :: i, j
    REAL(8), INTENT(IN)  :: pr, qr
    LOGICAL, INTENT(IN)  :: lcmp
    INTEGER, INTENT(OUT) :: ns
    LOGICAL, POINTER, INTENT(INOUT) :: ls(:)
    INTEGER, POINTER, INTENT(INOUT) :: is(:), js(:)
    REAL(8), POINTER, INTENT(INOUT) :: cs(:)
 
    !     Local parameters
    LOGICAL :: ijg, llg, lclo
    INTEGER :: iclo, gkind
    INTEGER :: lbx, lby, ubx, uby, nx, ny
    INTEGER :: istat, k
    !
    !---- initialize
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/2A/)') 'GETBLC ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
    ijg = gsu%PTR%IJG
    llg = gsu%PTR%LLG
    iclo = gsu%PTR%ICLO
    lclo = gsu%PTR%LCLO
    gkind = gsu%PTR%GKIND
    lbx = gsu%PTR%LBX;  lby = gsu%PTR%LBY;
    ubx = gsu%PTR%UBX;  uby = gsu%PTR%UBY;
    nx = gsu%PTR%NX;  ny = gsu%PTR%NY;
    !
    !---- check & deallocate
    IF ( ASSOCIATED(ls) ) THEN
      DEALLOCATE(ls);  NULLIFY(ls);
    END IF
    IF ( ASSOCIATED(is) ) THEN
      DEALLOCATE(is);  NULLIFY(is);
    END IF
    IF ( ASSOCIATED(js) ) THEN
      DEALLOCATE(js);  NULLIFY(js);
    END IF
    IF ( ASSOCIATED(cs) ) THEN
      DEALLOCATE(cs);  NULLIFY(cs);
    END IF
    !
    !---- set number of interpolation points and allocate arrays
    ns = 4
    ALLOCATE( ls(ns), is(ns), js(ns), cs(ns), stat=istat )
    IF ( istat .NE. 0 ) THEN
      WRITE(0,'(/1A,1A/)') 'GETBLC ERROR -- ', &
           'array allocation failed'
      CALL extcde (istat)
    END IF
    ls(:) = .true.
    cs(:) = zero
    !
    !---- 4 source points for the bilinear interpolation
    !     (4)------------------(3)
    !      |                    |
    !      |  PR                |
    !      |-----.              |
    !      |     |              |
    !      |     |QR            |
    !      |     |              |
    !     (1)------------------(2)
    is(1) = i  ;  js(1) = j  ;
    is(2) = i+1;  js(2) = j  ;
    is(3) = i+1;  js(3) = j+1;
    is(4) = i  ;  js(4) = j+1;
    !
    !---- apply index closure
    DO k=1,ns
      IF ( mod(iclo,2).EQ.0 ) &
           is(k) = lbx + mod(nx - 1 + mod(is(k) - lbx + 1, nx), nx)
      IF ( mod(iclo,3).EQ.0 ) &
           js(k) = lby + mod(ny - 1 + mod(js(k) - lby + 1, ny), ny)
      IF ( iclo.EQ.iclo_trpl .AND. js(k).GT.uby ) THEN
        is(k) = ubx + lbx - is(k)
        js(k) = 2*uby - js(k) + 1
      END IF
    END DO
    !
    !---- calculate bilinear interpolation coefficients
    IF ( lcmp ) THEN
      cs(1) = (one-pr)*(one-qr)
      cs(2) = pr*(one-qr)
      cs(3) = pr*qr
      cs(4) = (one-pr)*qr
    END IF
 
  END SUBROUTINE getblc
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE getbcc( GSU, I, J, PR, QR, LCMP, NS, LS, IS, JS, CS )
    !     *** INTERNAL SUBROUTINE ***
    !     Compute bicubic remap factors for a given point (P,Q)
    !     (I,J) = lower-left corner point of grid cell containing target point
    !     (PR,QR) = cell-relative coordinate of target point
    TYPE(t_gsu), INTENT(IN) :: gsu
    INTEGER, INTENT(IN)  :: i, j
    REAL(8), INTENT(IN)  :: pr, qr
    LOGICAL, INTENT(IN)  :: lcmp
    INTEGER, INTENT(OUT) :: ns
    LOGICAL, POINTER, INTENT(INOUT) :: ls(:)
    INTEGER, POINTER, INTENT(INOUT) :: is(:), js(:)
    REAL(8), POINTER, INTENT(INOUT) :: cs(:)
 
    !     Local parameters
    REAL(8), PARAMETER :: small = 1d-6
    LOGICAL :: ijg, llg, lclo
    INTEGER :: iclo, gkind
    INTEGER :: lbx, lby, ubx, uby, nx, ny
    INTEGER :: istat, p, q, ii, jj, k, l, n, m
    REAL(8) :: pv(0:3), qv(0:3), pw(0:3), qw(0:3)
    REAL(8) :: a(0:1,0:1,0:3)
    REAL(8) :: w(0:3,0:3) = reshape((/  1,  0, -3,  2, &
         0,  0,  3, -2, &
         0,  1, -2,  1, &
         0,  0, -1,  1 /), &
         (/4,4/))
    INTEGER, PARAMETER :: nfd = 2 ! finite-difference order (even)
    INTEGER :: kfd(0:nfd,0:nfd) = reshape((/  0,  1,  2, &
         -1,  0,  1, &
         -2, -1,  0 /), &
         (/nfd+1,nfd+1/))
    REAL(8) :: cfd(0:nfd,0:nfd) = half* reshape((/ -3,  4, -1, &
         -1,  0,  1, &
         1, -4,  3 /), &
         (/nfd+1,nfd+1/))
    REAL(8) :: cs2d(-nfd/2:nfd,-nfd/2:nfd)
    !
    !---- initialize
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/2A/)') 'GETBCC ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
    ijg = gsu%PTR%IJG
    llg = gsu%PTR%LLG
    iclo = gsu%PTR%ICLO
    lclo = gsu%PTR%LCLO
    gkind = gsu%PTR%GKIND
    lbx = gsu%PTR%LBX;  lby = gsu%PTR%LBY;
    ubx = gsu%PTR%UBX;  uby = gsu%PTR%UBY;
    nx = gsu%PTR%NX;  ny = gsu%PTR%NY;
    !
    !---- check & deallocate
    IF ( ASSOCIATED(ls) ) THEN
      DEALLOCATE(ls);  NULLIFY(ls);
    END IF
    IF ( ASSOCIATED(is) ) THEN
      DEALLOCATE(is);  NULLIFY(is);
    END IF
    IF ( ASSOCIATED(js) ) THEN
      DEALLOCATE(js);  NULLIFY(js);
    END IF
    IF ( ASSOCIATED(cs) ) THEN
      DEALLOCATE(cs);  NULLIFY(cs);
    END IF
    !
    !---- setup table of bicubic coefficients
    !
    !    (0,1)----------------(1,1)
    !      |                    |
    !      |                    |
    !      |-----x(Pr,Qr)       |
    !      |     |              |
    !      |     |              |
    !      |     |              |
    !    (0,0)----------------(1,0)
    !
    !     Pv = [ Pr**0, Pr**1, Pr**2, Pr**3 ]^t
    !     Qv = [ Qr**0, Qr**1, Qr**2, Qr**3 ]^t
    !
    !     Pw = W*Pv
    !     Qw = W*Qv
    !
    !     A(i,j,0) = Pw(i  )*Qw(j  )
    !     A(i,j,1) = Pw(i+2)*Qw(j  )
    !     A(i,j,2) = Pw(i  )*Qw(j+2)
    !     A(i,j,3) = Pw(i+2)*Qw(j+2)
    !
    !     F(Pr,Qr) = SUM[i=0:1]{ SUM[j=0:1]{
    !                    A(i,j,0) *   F(i,j) +
    !                    A(i,j,1) *  Fp(i,j) +
    !                    A(i,j,2) *  Fq(i,j) +
    !                    A(i,j,3) * Fpq(i,j) } }
    !
    DO k=0,3
      pv(k) = pr**k
      qv(k) = qr**k
    END DO
    pw = matmul(pv,w)
    qw = matmul(qv,w)
    DO jj=0,1
      DO ii=0,1
        a(ii,jj,0) = pw(ii)  *qw(jj)
        a(ii,jj,1) = pw(ii+2)*qw(jj)
        a(ii,jj,2) = pw(ii)  *qw(jj+2)
        a(ii,jj,3) = pw(ii+2)*qw(jj+2)
      END DO
    END DO
    !
    !---- source points for the bicubic interpolation
    !     The additional points are needed to construct derivatives (centered in space).
    !     If boundary points are not available one sided finite differences are used.
    !
    !     (-1, 2).... (0, 2).....(1, 2).....(2, 2)
    !        .          .          .          .
    !        .          .          .          .
    !        .          .          .          .
    !        .          .          .          .
    !        .          .          .          .
    !     (-1, 1).....(0, 1)-----(1, 1).....(2, 1)
    !        .          |          |          .
    !        .          |  Pr      |          .
    !        .          |----x     |          .
    !        .          |    |Qr   |          .
    !        .          |    |     |          .
    !     (-1, 0).....(0, 0)-----(1, 0).....(2, 0)
    !        .          .          .          .
    !        .          .          .          .
    !        .          .          .          .
    !        .          .          .          .
    !        .          .          .          .
    !     (-1,-1).....(0,-1).....(1,-1).....(2,-1)
    !
    !      Fp(i,j) = SUM[n=0:NFD]{ CFD(n,l)*F(i+KFD(n,l),j) }
    !      Fq(i,j) = SUM[n=0:NFD]{ CFD(n,k)*F(i,j+KFD(n,k)) }
    !     Fpq(i,j) = SUM[n=0:NFD]{ SUM[m=0:NFD]{
    !                    CFD(n,l)*CFD(m,k)*F(i+KFD(n,l),j+KFD(m,k)) } }
    !
    !     (i,j) = (0,0),(1,0),(1,1),(0,1)
    !     l or k = 0 : one-sided finite-difference (left)
    !     l or k = 1 : centered finite-difference
    !     l or k = 2 : one-sided finite-difference (right)
    !
    cs2d = zero
    DO jj=0,1
      DO ii=0,1
        p = i + ii
        q = j + jj
        IF ( mod(iclo,2).EQ.0 ) THEN
          k = nfd/2
        ELSE
          IF (p-lbx.LT.nfd/2) THEN
            k = p - lbx
          ELSE IF (ubx-p.LT.nfd/2) THEN
            k = nfd + p - ubx
          ELSE
            k = nfd/2
          END IF
        END IF
        IF ( mod(iclo,3).EQ.0 ) THEN
          l = nfd/2
        ELSE IF ( iclo.EQ.iclo_trpl ) THEN
          IF (q-lby.LT.nfd/2) THEN
            l = q - lby
          ELSE
            l = nfd/2
          END IF
        ELSE
          IF (q-lby.LT.nfd/2) THEN
            l = q - lby
          ELSE IF (uby-q.LT.nfd/2) THEN
            l = nfd + q - uby
          ELSE
            l = nfd/2
          END IF
        END IF
        cs2d(ii,jj) = cs2d(ii,jj) + a(ii,jj,0)
        DO n=0,nfd
          cs2d(ii+kfd(n,k),jj) = cs2d(ii+kfd(n,k),jj) &
               + a(ii,jj,1)*cfd(n,k)
          cs2d(ii,jj+kfd(n,l)) = cs2d(ii,jj+kfd(n,l)) &
               + a(ii,jj,2)*cfd(n,l)
          DO m=0,nfd
            cs2d(ii+kfd(n,k),jj+kfd(m,l)) = &
                 cs2d(ii+kfd(n,k),jj+kfd(m,l)) &
                 + a(ii,jj,3)*cfd(n,k)*cfd(m,l)
          END DO
        END DO
      END DO
    END DO
    !
    !---- set number of interpolation points and allocate arrays
    ns = count( abs(cs2d) .GT. small )
    ALLOCATE( ls(ns), is(ns), js(ns), cs(ns), stat=istat )
    IF ( istat .NE. 0 ) THEN
      WRITE(0,'(/1A,1A/)') 'GETBCC ERROR -- ', &
           'array allocation failed'
      CALL extcde (istat)
    END IF
    ls(:) = .true.
    cs(:) = zero
    !
    !---- load arrays and apply index closure
    ns = 0
    DO jj=-nfd/2,nfd
      DO ii=-nfd/2,nfd
        IF ( abs(cs2d(ii,jj)) .GT. small ) THEN
          ns = ns + 1
          is(ns) = i + ii
          js(ns) = j + jj
          cs(ns) = cs2d(ii,jj)
          IF ( mod(iclo,2).EQ.0 ) &
               is(ns) = lbx + mod(nx - 1 + mod(is(ns) - lbx + 1, nx), nx)
          IF ( mod(iclo,3).EQ.0 ) &
               js(ns) = lby + mod(ny - 1 + mod(js(ns) - lby + 1, ny), ny)
          IF ( iclo.EQ.iclo_trpl .AND. js(ns).GT.uby ) THEN
            is(ns) = ubx + lbx - is(ns)
            js(ns) = 2*uby - js(ns) + 1
          END IF
        END IF
      END DO
    END DO
 
  END SUBROUTINE getbcc
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE getgfc( GSU, I, J, PR, QR, WIDTH, LCMP, NS, LS, IS, JS, CS )
    !     *** INTERNAL SUBROUTINE ***
    !     Compute gaussian filter remap factors for a given point (P,Q)
    !     (I,J) = lower-left corner point of grid cell containing target point
    !     (PR,QR) = cell-relative coordinate of target point
    !     Double precision interface
    TYPE(t_gsu), INTENT(IN) :: gsu
    INTEGER, INTENT(IN)  :: i, j
    REAL(8), INTENT(IN)  :: pr, qr
    REAL(8), INTENT(IN)  :: width
    LOGICAL, INTENT(IN)  :: lcmp
    INTEGER, INTENT(OUT) :: ns
    LOGICAL, POINTER, INTENT(INOUT) :: ls(:)
    INTEGER, POINTER, INTENT(INOUT) :: is(:), js(:)
    REAL(8), POINTER, INTENT(INOUT) :: cs(:)
 
    !     Local parameters
    !     Note, width (=nsig*sigma) is set to max(width,width_min)
    !     so that the filter includes at least one source point.
    REAL(8), PARAMETER :: nsig = 6.0d0
    REAL(8), PARAMETER :: width_min = 1.5d0
    LOGICAL :: ijg, llg, lclo
    INTEGER :: iclo, gkind
    INTEGER :: lbx, lby, ubx, uby, nx, ny
    INTEGER :: istat, k
    INTEGER :: ii, jj, imin, jmin, imax, jmax
    REAL(8) :: wdth, sig2, rmax, r2mx, sfac, r2, gij, gsum
    !
    !---- initialize
    IF ( .NOT.ASSOCIATED(gsu%PTR) ) THEN
      WRITE(0,'(/2A/)') 'GETBLC ERROR -- ', &
           'grid search utility object not created'
      CALL extcde (1)
    END IF
    ijg = gsu%PTR%IJG
    llg = gsu%PTR%LLG
    iclo = gsu%PTR%ICLO
    lclo = gsu%PTR%LCLO
    gkind = gsu%PTR%GKIND
    lbx = gsu%PTR%LBX;  lby = gsu%PTR%LBY;
    ubx = gsu%PTR%UBX;  uby = gsu%PTR%UBY;
    nx = gsu%PTR%NX;  ny = gsu%PTR%NY;
    wdth = max(width,width_min)
    sig2 = (wdth/nsig)**2
    sfac = -0.5d0/sig2
    rmax = 0.5d0*wdth
    r2mx = rmax**2
    imin = int(min(zero,pr)-rmax)
    jmin = int(min(zero,qr)-rmax)
    imax = ceiling(max(zero,pr)+rmax)
    jmax = ceiling(max(zero,qr)+rmax)
    !
    !---- check & deallocate
    IF ( ASSOCIATED(ls) ) THEN
      DEALLOCATE(ls);  NULLIFY(ls);
    END IF
    IF ( ASSOCIATED(is) ) THEN
      DEALLOCATE(is);  NULLIFY(is);
    END IF
    IF ( ASSOCIATED(js) ) THEN
      DEALLOCATE(js);  NULLIFY(js);
    END IF
    IF ( ASSOCIATED(cs) ) THEN
      DEALLOCATE(cs);  NULLIFY(cs);
    END IF
    !
    !---- set number of interpolation points and allocate arrays
    ns = (imax-imin+1)*(jmax-jmin+1)
    ALLOCATE( ls(ns), is(ns), js(ns), cs(ns), stat=istat )
    IF ( istat .NE. 0 ) THEN
      WRITE(0,'(/1A,1A/)') 'GETGFC ERROR -- ', &
           'array allocation failed'
      CALL extcde (istat)
    END IF
    ls(:) = .false.
    cs(:) = zero
    !
    !---- calculate filter coefficients
    gsum = zero
    DO jj=jmin,jmax
      DO ii=imin,imax
        k = (imax-imin+1)*(jj-jmin) + ii - imin + 1
        !-------- source points for the filter
        is(k) = i + ii
        js(k) = j + jj
        !-------- apply index closure
        IF ( mod(iclo,2).EQ.0 ) &
             is(k) = lbx + mod(nx - 1 + mod(is(k) - lbx + 1, nx), nx)
        IF ( mod(iclo,3).EQ.0 ) &
             js(k) = lby + mod(ny - 1 + mod(js(k) - lby + 1, ny), ny)
        IF ( iclo.EQ.iclo_trpl .AND. js(k).GT.uby ) THEN
          is(k) = ubx + lbx - is(k)
          js(k) = 2*uby - js(k) + 1
        END IF
        !-------- skip if source point is outside domain
        IF ( is(k).LT.lbx .OR. is(k).GT.ubx ) cycle
        IF ( js(k).LT.lby .OR. js(k).GT.uby ) cycle
        !-------- compute distance
        r2 = (pr - ii)**2 + (qr - jj)**2
        !         IF ( R2.GT.R2MX ) CYCLE
        !-------- compute coefficient
        ls(k) = .true.
        IF ( lcmp ) THEN
          gij = exp( sfac*r2 )
          gsum = gsum + gij
          cs(k) = gij
        END IF
      END DO
    END DO
    IF ( lcmp ) THEN
      WHERE ( ls ) cs = cs/gsum
    END IF
 
  END SUBROUTINE getgfc
  !/
  !/ ------------------------------------------------------------------- /
  !/
#define DXYDP_SINGLE_POINT_WIDE_CHANNEL_ERROR
#undef  DXYDP_SINGLE_POINT_WIDE_CHANNEL_WARNING
  SUBROUTINE dxydp( N, K, C, IJG, LLG, ICLO, &
       PTILED, QTILED, PRANGE, QRANGE, &
       LB, UB, P, Q, DXDP, DYDP, MASK, &
       X4, Y4, X8, Y8, RC )
    !     *** INTERNAL SUBROUTINE ***
    INTEGER, INTENT(IN)   :: n
    INTEGER, INTENT(IN)   :: k(0:n,0:n,1:n)
    REAL(8), INTENT(IN)   :: c(0:n,0:n,1:n)
    LOGICAL, INTENT(IN)   :: ijg
    LOGICAL, INTENT(IN)   :: llg
    INTEGER, INTENT(IN)   :: iclo
    LOGICAL, INTENT(IN)   :: ptiled, qtiled
    INTEGER, INTENT(IN)   :: prange(2), qrange(2)
    INTEGER, INTENT(IN)   :: lb(2), ub(2)
    INTEGER, INTENT(IN)   :: p, q
    REAL(8), INTENT(OUT)  :: dxdp, dydp
    LOGICAL, INTENT(IN),  OPTIONAL :: mask(lb(1):ub(1),lb(2):ub(2))
    REAL(4), INTENT(IN),  OPTIONAL :: x4(lb(1):ub(1),lb(2):ub(2))
    REAL(4), INTENT(IN),  OPTIONAL :: y4(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(IN),  OPTIONAL :: x8(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(IN),  OPTIONAL :: y8(lb(1):ub(1),lb(2):ub(2))
    INTEGER, INTENT(OUT), OPTIONAL :: rc
 
    !     Local parameters
    INTEGER, PARAMETER :: m = 1 ! order of derivative
    LOGICAL, PARAMETER :: debug = .false.
    CHARACTER(64) :: fstr
    LOGICAL :: comp_m, type_r4, type_r8
    INTEGER :: ihem
    INTEGER :: np, nq, lbp, lbq, ubp, ubq, p0, q0
    INTEGER :: istat=0, i, l, ii, ni, ii0, iin
    INTEGER :: kp(0:n), kq(0:n)
    LOGICAL :: mp(0:n)
    REAL(8) :: xp(0:n)
    REAL(8) :: yp(0:n)
    REAL(8) :: up(0:n)
    REAL(8) :: vp(0:n)
    REAL(8) :: x0, y0, lon0, lat0, c0
    REAL(8) :: d1dp, d2dp
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Check and setup inputs
    !
    IF ( PRESENT(rc) ) rc = 0
 
    type_r4 = PRESENT(x4).AND.PRESENT(y4)
    type_r8 = PRESENT(x8).AND.PRESENT(y8)
    IF ( .NOT.type_r4.AND..NOT.type_r8 ) THEN
      WRITE(0,'(/1A,1A/)') 'DXYDP ERROR -- ', &
           'no input grid coordinates specified'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    np = prange(2) - prange(1) + 1
    nq = qrange(2) - qrange(1) + 1
 
    IF ( ijg ) THEN
      lbp = lb(1); lbq = lb(2)
      ubp = ub(1); ubq = ub(2)
    ELSE
      lbp = lb(2); lbq = lb(1)
      ubp = ub(2); ubq = ub(1)
    END IF
 
    IF ( p.LT.lbp .OR. p.GT.ubp .OR. q.LT.lbq .OR. q.GT.ubq ) THEN
      WRITE(0,'(/1A,/1A,1L2,5I6,/1A,1L2,5I6/)') 'DXYDP ERROR -- '// &
           'input index coordinates outside input array bounds', &
           'DXYDP ERROR -- PTILED,PRANGE,P,LBP,UBP:',ptiled,prange,p,lbp,ubp, &
           'DXYDP ERROR -- QTILED,QRANGE,Q,LBQ,UBQ:',qtiled,qrange,q,lbq,ubq
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    p0 = p
    q0 = q
    IF ( mod(iclo,2).EQ.0 ) &
         p0 = prange(1) + mod(np - 1 + mod(p0 - prange(1) + 1, np), np)
    IF ( mod(iclo,3).EQ.0 ) &
         q0 = qrange(1) + mod(nq - 1 + mod(q0 - qrange(1) + 1, nq), nq)
    IF ( iclo.EQ.iclo_trpl .AND. q0.GT.qrange(2) ) THEN
      p0 = prange(2) + prange(1) - p0
      q0 = 2*qrange(2) - q0 + 1
    END IF
    IF ( p0.LT.prange(1) .OR. p0.GT.prange(2) .OR. &
         q0.LT.qrange(1) .OR. q0.GT.qrange(2) ) THEN
      WRITE(0,'(/1A,/1A,4I6,/1A,4I6/)') 'DXYDP ERROR -- '// &
           'shifted input index coordinates outside allowed range', &
           'DXYDP ERROR -- PRANGE,P,P0:',prange,p,p0, &
           'DXYDP ERROR -- QRANGE,Q,Q0:',qrange,q,q0
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    dxdp = zero
    dydp = zero
    comp_m = PRESENT(mask)
    IF ( comp_m ) THEN
      IF ( ijg ) THEN
        IF ( mask(p0,q0) ) RETURN
      ELSE
        IF ( mask(q0,p0) ) RETURN
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Compute DX/DP & DY/DP
    !
    IF ( mod(iclo,2).EQ.0 ) THEN
      i = n/2
    ELSE
      IF (p0-prange(1).LT.n/2) THEN
        i = p0 - prange(1)
      ELSE IF (prange(2)-p0.LT.n/2) THEN
        i = n + p0 - prange(2)
      ELSE
        i = n/2
      END IF
    END IF
 
    kp(:) = p + k(:,i,n)
    kq(:) = q
    IF ( .NOT.ptiled ) THEN
      IF ( mod(iclo,2).EQ.0 ) THEN
        kp = prange(1) + mod(np - 1 + mod(kp - prange(1) + 1, np), np)
      END IF
    END IF
 
    IF ( minval(kp).LT.lbp .OR. maxval(kp).GT.ubp .OR. &
         minval(kq).LT.lbq .OR. maxval(kq).GT.ubq ) THEN
      WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DXYDP ERROR -- '// &
           'stencil index coordinates outside array bounds', &
           'DXYDP ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', &
           ptiled,prange,p,p0,lbp,ubp,minval(kp),maxval(kp), &
           'DXYDP ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', &
           qtiled,qrange,q,q0,lbq,ubq,minval(kq),maxval(kq)
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    DO l = 0, n
      IF ( ijg ) THEN
        IF ( comp_m ) mp(l) = mask(kp(l),kq(l))
        IF ( type_r4 ) THEN
          xp(l) = x4(kp(l),kq(l))
          yp(l) = y4(kp(l),kq(l))
        ELSE
          xp(l) = x8(kp(l),kq(l))
          yp(l) = y8(kp(l),kq(l))
        END IF
      ELSE
        IF ( comp_m ) mp(l) = mask(kq(l),kp(l))
        IF ( type_r4 ) THEN
          xp(l) = x4(kq(l),kp(l))
          yp(l) = y4(kq(l),kp(l))
        ELSE
          xp(l) = x8(kq(l),kp(l))
          yp(l) = y8(kq(l),kp(l))
        END IF
      END IF
    END DO
 
    ii = i
    ni = n
    ii0 = 0
    iin = n
    IF ( comp_m ) THEN
      DO l = i-1, 0, -1
        IF ( mp(l) ) THEN
          mp(0:l) = .true.
          EXIT
        END IF
      END DO
      DO l = i+1, n
        IF ( mp(l) ) THEN
          mp(l:n) = .true.
          EXIT
        END IF
      END DO
      ii = count(.NOT.mp(0:i)) - 1
      ni = count(.NOT.mp(0:n)) - 1
      ii0 = i - ii
      iin = ii0 + ni
    END IF
#ifdef DXYDP_SINGLE_POINT_WIDE_CHANNEL_ERROR
    IF ( ni.LE.0 ) THEN
      WRITE(0,'(/1A,1A,4I6/)') 'DXYDP ERROR -- ', &
           'single point wide channel not allowed',p,q,p0,q0
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
#endif
 
    IF ( ni.GT.0 ) THEN
      IF ( llg ) THEN
#define DXYDP_USE_SPLX
#ifdef DXYDP_USE_SPLX
        IF ( ijg ) THEN
          IF ( type_r4 ) THEN
            x0 = x4(p,q); y0 = y4(p,q);
          ELSE
            x0 = x8(p,q); y0 = y8(p,q);
          END IF
        ELSE
          IF ( type_r4 ) THEN
            x0 = x4(q,p); y0 = y4(q,p);
          ELSE
            x0 = x8(q,p); y0 = y8(q,p);
          END IF
        END IF
        ihem = 1; IF (maxval(yp(ii0:iin)).LT.zero) ihem = -1;
        lon0 = zero; lat0 = sign(d90,real(ihem,8));
        c0 = d90 - abs(y0)
        CALL w3splx(lon0,lat0,c0,xp(ii0:iin),yp(ii0:iin), &
             up(ii0:iin),vp(ii0:iin))
        d1dp = dot_product(c(0:ni,ii,ni),up(ii0:iin))
        d2dp = dot_product(c(0:ni,ii,ni),vp(ii0:iin))
        CALL spddp(lon0,c0,ihem,x0,y0,d1dp,d2dp,dxdp,dydp)
#else
        dxdp = dot_product(c(0:ni,ii,ni),xp(ii0:iin))
        dydp = dot_product(c(0:ni,ii,ni),yp(ii0:iin))
#endif
      ELSE !.NOT.LLG
        dxdp = dot_product(c(0:ni,ii,ni),xp(ii0:iin))
        dydp = dot_product(c(0:ni,ii,ni),yp(ii0:iin))
      END IF !.NOT.LLG
      IF ( debug ) THEN
        WRITE(fstr,'(A,I0,A,I0,A)') &
             '(/1A,12I8,5(/1A,2E16.8),/1A,', &
             ni+1,'I16,3(/1A,',ni+1,'E16.8))'
        WRITE(*,trim(fstr)) &
             'DXYDP -- PRANGE,QRANGE,P,Q,P0,Q0,NI,II,II0,IIN:',&
             prange,qrange,p,q,p0,q0,ni,ii,ii0,iin,  &
             'DXYDP --   X0,  Y0:',x0,y0, &
             'DXYDP -- LON0,LAT0:',lon0,lat0, &
             'DXYDP --   C0,IHEM:',c0,real(ihem), &
             'DXYDP -- D1DP,D2DP:',d1dp,d2dp, &
             'DXYDP -- DXDP,DYDP:',dxdp,dydp, &
             'DXYDP --  K:', k(0:ni,ii,ni), &
             'DXYDP --  C:', c(0:ni,ii,ni), &
             'DXYDP -- XP:',xp(ii0:iin), &
             'DXYDP -- YP:',yp(ii0:iin)
      END IF
    ELSE
#ifdef DXYDP_SINGLE_POINT_WIDE_CHANNEL_WARNING
      WRITE(0,'(/1A,1A,4I6/)') 'DXYDP WARNING -- ', &
           'single point wide channel, DXDP & DYDP set to zero:',p,q,p0,q0
#endif
      dxdp = zero
      dydp = zero
    END IF
 
  END SUBROUTINE dxydp
  !/
  !/ ------------------------------------------------------------------- /
  !/
#define DXYDQ_SINGLE_POINT_WIDE_CHANNEL_ERROR
#undef  DXYDQ_SINGLE_POINT_WIDE_CHANNEL_WARNING
  SUBROUTINE dxydq( N, K, C, IJG, LLG, ICLO, &
       PTILED, QTILED, PRANGE, QRANGE, &
       LB, UB, P, Q, DXDQ, DYDQ, MASK, &
       X4, Y4, X8, Y8, RC )
    !     *** INTERNAL SUBROUTINE ***
    INTEGER, INTENT(IN)   :: n
    INTEGER, INTENT(IN)   :: k(0:n,0:n,1:n)
    REAL(8), INTENT(IN)   :: c(0:n,0:n,1:n)
    LOGICAL, INTENT(IN)   :: ijg
    LOGICAL, INTENT(IN)   :: llg
    INTEGER, INTENT(IN)   :: iclo
    LOGICAL, INTENT(IN)   :: ptiled, qtiled
    INTEGER, INTENT(IN)   :: prange(2), qrange(2)
    INTEGER, INTENT(IN)   :: lb(2), ub(2)
    INTEGER, INTENT(IN)   :: p, q
    REAL(8), INTENT(OUT)  :: dxdq, dydq
    LOGICAL, INTENT(IN),  OPTIONAL :: mask(lb(1):ub(1),lb(2):ub(2))
    REAL(4), INTENT(IN),  OPTIONAL :: x4(lb(1):ub(1),lb(2):ub(2))
    REAL(4), INTENT(IN),  OPTIONAL :: y4(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(IN),  OPTIONAL :: x8(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(IN),  OPTIONAL :: y8(lb(1):ub(1),lb(2):ub(2))
    INTEGER, INTENT(OUT), OPTIONAL :: rc
 
    !     Local parameters
    INTEGER, PARAMETER :: m = 1 ! order of derivative
    LOGICAL, PARAMETER :: debug = .false.
    CHARACTER(64) :: fstr
    LOGICAL :: comp_m, type_r4, type_r8
    INTEGER :: ihem
    INTEGER :: np, nq, lbp, lbq, ubp, ubq, p0, q0
    INTEGER :: istat=0, j, l, jj, nj, jj0, jjn
    INTEGER :: kp(0:n), kq(0:n)
    LOGICAL :: mq(0:n)
    REAL(8) :: xq(0:n)
    REAL(8) :: yq(0:n)
    REAL(8) :: uq(0:n)
    REAL(8) :: vq(0:n)
    REAL(8) :: x0, y0, lon0, lat0, c0
    REAL(8) :: d1dq, d2dq
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Check and setup inputs
    !
    IF ( PRESENT(rc) ) rc = 0
 
    type_r4 = PRESENT(x4).AND.PRESENT(y4)
    type_r8 = PRESENT(x8).AND.PRESENT(y8)
    IF ( .NOT.type_r4.AND..NOT.type_r8 ) THEN
      WRITE(0,'(/1A,1A/)') 'DXYDQ ERROR -- ', &
           'no input grid coordinates specified'
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    np = prange(2) - prange(1) + 1
    nq = qrange(2) - qrange(1) + 1
 
    IF ( ijg ) THEN
      lbp = lb(1); lbq = lb(2)
      ubp = ub(1); ubq = ub(2)
    ELSE
      lbp = lb(2); lbq = lb(1)
      ubp = ub(2); ubq = ub(1)
    END IF
 
    IF ( p.LT.lbp .OR. p.GT.ubp .OR. q.LT.lbq .OR. q.GT.ubq ) THEN
      WRITE(0,'(/1A,/1A,1L2,5I6,/1A,1L2,5I6/)') 'DXYDQ ERROR -- '// &
           'input index coordinates outside input array bounds', &
           'DXYDQ ERROR -- PTILED,PRANGE,P,LBP,UBP:',ptiled,prange,p,lbp,ubp, &
           'DXYDQ ERROR -- QTILED,QRANGE,Q,LBQ,UBQ:',qtiled,qrange,q,lbq,ubq
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    p0 = p
    q0 = q
    IF ( mod(iclo,2).EQ.0 ) &
         p0 = prange(1) + mod(np - 1 + mod(p0 - prange(1) + 1, np), np)
    IF ( mod(iclo,3).EQ.0 ) &
         q0 = qrange(1) + mod(nq - 1 + mod(q0 - qrange(1) + 1, nq), nq)
    IF ( iclo.EQ.iclo_trpl .AND. q0.GT.qrange(2) ) THEN
      p0 = prange(2) + prange(1) - p0
      q0 = 2*qrange(2) - q0 + 1
    END IF
    IF ( p0.LT.prange(1) .OR. p0.GT.prange(2) .OR. &
         q0.LT.qrange(1) .OR. q0.GT.qrange(2) ) THEN
      WRITE(0,'(/1A,/1A,4I6,/1A,4I6/)') 'DXYDQ ERROR -- '// &
           'shifted input index coordinates outside allowed range', &
           'DXYDQ ERROR -- PRANGE,P,P0:',prange,p,p0, &
           'DXYDQ ERROR -- QRANGE,Q,Q0:',qrange,q,q0
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    dxdq = zero
    dydq = zero
    comp_m = PRESENT(mask)
    IF ( comp_m ) THEN
      IF ( ijg ) THEN
        IF ( mask(p0,q0) ) RETURN
      ELSE
        IF ( mask(q0,p0) ) RETURN
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Compute DX/DQ & DY/DQ
    !
    IF ( mod(iclo,3).EQ.0 ) THEN
      j = n/2
    ELSE IF ( iclo.EQ.iclo_trpl ) THEN
      IF (q0-qrange(1).LT.n/2) THEN
        j = q0 - qrange(1)
      ELSE
        j = n/2
      END IF
    ELSE
      IF (q0-qrange(1).LT.n/2) THEN
        j = q0 - qrange(1)
      ELSE IF (qrange(2)-q0.LT.n/2) THEN
        j = n + q0 - qrange(2)
      ELSE
        j = n/2
      END IF
    END IF
 
    kp(:) = p
    kq(:) = q + k(:,j,n)
    IF ( .NOT.qtiled ) THEN
      IF ( mod(iclo,3).EQ.0 ) THEN
        kq = qrange(1) + mod(nq - 1 + mod(kq - qrange(1) + 1, nq), nq)
      END IF
      IF ( iclo.EQ.iclo_trpl .AND. .NOT.ptiled ) THEN
        WHERE ( kq.GT.qrange(2) )
          kp = prange(2) + prange(1) - kp
          kq = 2*qrange(2) - kq + 1
        END WHERE
      END IF
    END IF
 
    IF ( minval(kp).LT.lbp .OR. maxval(kp).GT.ubp .OR. &
         minval(kq).LT.lbq .OR. maxval(kq).GT.ubq ) THEN
      WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DXYDQ ERROR -- '// &
           'stencil index coordinates outside array bounds', &
           'DXYDQ ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', &
           ptiled,prange,p,p0,lbp,ubp,minval(kp),maxval(kp), &
           'DXYDQ ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', &
           qtiled,qrange,q,q0,lbq,ubq,minval(kq),maxval(kq)
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    DO l = 0, n
      IF ( ijg ) THEN
        IF ( comp_m ) mq(l) = mask(kp(l),kq(l))
        IF ( type_r4 ) THEN
          xq(l) = x4(kp(l),kq(l))
          yq(l) = y4(kp(l),kq(l))
        ELSE
          xq(l) = x8(kp(l),kq(l))
          yq(l) = y8(kp(l),kq(l))
        END IF
      ELSE
        IF ( comp_m ) mq(l) = mask(kq(l),kp(l))
        IF ( type_r4 ) THEN
          xq(l) = x4(kq(l),kp(l))
          yq(l) = y4(kq(l),kp(l))
        ELSE
          xq(l) = x8(kq(l),kp(l))
          yq(l) = y8(kq(l),kp(l))
        END IF
      END IF
    END DO
 
    jj = j
    nj = n
    jj0 = 0
    jjn = n
    IF ( comp_m ) THEN
      DO l = j-1, 0, -1
        IF ( mq(l) ) THEN
          mq(0:l) = .true.
          EXIT
        END IF
      END DO
      DO l = j+1, n
        IF ( mq(l) ) THEN
          mq(l:n) = .true.
          EXIT
        END IF
      END DO
      jj = count(.NOT.mq(0:j)) - 1
      nj = count(.NOT.mq(0:n)) - 1
      jj0 = j - jj
      jjn = jj0 + nj
    END IF
#ifdef DXYDQ_SINGLE_POINT_WIDE_CHANNEL_ERROR
    IF ( nj.LE.0 ) THEN
      WRITE(0,'(/1A,1A,4I6/)') 'DXYDQ ERROR -- ', &
           'single point wide channel not allowed',p,q,p0,q0
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
#endif
 
    IF ( nj.GT.0 ) THEN
      IF ( llg ) THEN
#define DXYDQ_USE_SPLX
#ifdef DXYDQ_USE_SPLX
        IF ( ijg ) THEN
          IF ( type_r4 ) THEN
            x0 = x4(p,q); y0 = y4(p,q);
          ELSE
            x0 = x8(p,q); y0 = y8(p,q);
          END IF
        ELSE
          IF ( type_r4 ) THEN
            x0 = x4(q,p); y0 = y4(q,p);
          ELSE
            x0 = x8(q,p); y0 = y8(q,p);
          END IF
        END IF
        ihem = 1; IF (maxval(yq(jj0:jjn)).LT.zero) ihem = -1;
        lon0 = zero; lat0 = sign(d90,real(ihem,8));
        c0 = d90 - abs(y0)
        CALL w3splx(lon0,lat0,c0,xq(jj0:jjn),yq(jj0:jjn), &
             uq(jj0:jjn),vq(jj0:jjn))
        d1dq = dot_product(c(0:nj,jj,nj),uq(jj0:jjn))
        d2dq = dot_product(c(0:nj,jj,nj),vq(jj0:jjn))
        CALL spddq(lon0,c0,ihem,x0,y0,d1dq,d2dq,dxdq,dydq)
#else
        dxdq = dot_product(c(0:nj,jj,nj),xq(jj0:jjn))
        dydq = dot_product(c(0:nj,jj,nj),yq(jj0:jjn))
#endif
      ELSE !.NOT.LLG
        dxdq = dot_product(c(0:nj,jj,nj),xq(jj0:jjn))
        dydq = dot_product(c(0:nj,jj,nj),yq(jj0:jjn))
      END IF !.NOT.LLG
      IF ( debug ) THEN
        WRITE(fstr,'(A,I0,A,I0,A)') &
             '(/1A,12I8,5(/1A,2E16.8),/1A,', &
             nj+1,'I16,3(/1A,',nj+1,'E16.8))'
        WRITE(*,trim(fstr)) &
             'DXYDQ -- PRANGE,QRANGE,P,Q,P0,Q0,NJ,JJ,JJ0,JJN:',&
             prange,qrange,p,q,p0,q0,nj,jj,jj0,jjn,  &
             'DXYDQ --   X0,  Y0:',x0,y0, &
             'DXYDQ -- LON0,LAT0:',lon0,lat0, &
             'DXYDQ --   C0,IHEM:',c0,real(ihem), &
             'DXYDQ -- D1DQ,D1DQ:',d1dq,d1dq, &
             'DXYDQ -- DXDQ,DYDQ:',dxdq,dydq, &
             'DXYDQ --  K:', k(0:nj,jj,nj), &
             'DXYDQ --  C:', c(0:nj,jj,nj), &
             'DXYDQ -- XQ:',xq(jj0:jjn), &
             'DXYDQ -- YQ:',yq(jj0:jjn)
      END IF
    ELSE
#ifdef DXYDQ_SINGLE_POINT_WIDE_CHANNEL_WARNING
      WRITE(0,'(/1A,1A,4I6/)') 'DXYDQ WARNING -- ', &
           'single point wide channel, DXDQ & DYDQ set to zero:',p,q,p0,q0
#endif
      dxdq = zero
      dydq = zero
    END IF
 
  END SUBROUTINE dxydq
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE spddp( LAM0, C0, IHEM, LAM, PHI, DXDP, DYDP, &
       DLAMDP, DPHIDP )
    !     *** INTERNAL SUBROUTINE ***
    !     Routine to compute polar stereographic transformation of
    !     grid derivatives dx/dp & dy/dp to dlam/dp & dphi/dp.
    !
    !     mu = lam - lam0
    !     nu = pi/4 - alpha*phi/2
    !     k0 = cos(c0/2)**2
    !
    !     dlam/dx = (     1/(2*R*k0)) * cot(nu)   * cos(mu)
    !     dlam/dy = ( alpha/(2*R*k0)) * cot(nu)   * sin(mu)
    !     dphi/dx = (-alpha/(  R*k0)) * cos(nu)^2 * sin(mu)
    !     dphi/dy = (     1/(  R*k0)) * cos(nu)^2 * cos(mu)
    !
    !     dlam/dp = dx/dp*dlam/dx + dy/dp*dlam/dy
    !     dphi/dp = dx/dp*dphi/dx + dy/dp*dphi/dy
    !     dlam/dq = dx/dq*dlam/dx + dy/dq*dlam/dy
    !     dphi/dq = dx/dq*dphi/dx + dy/dq*dphi/dy
    !
    REAL(8),INTENT(IN) :: lam0, c0
    INTEGER,INTENT(IN) :: ihem
    REAL(8),INTENT(IN) :: lam, phi
    REAL(8),INTENT(IN) :: dxdp, dydp
    REAL(8),INTENT(OUT):: dlamdp, dphidp
 
    !     Local parameters
    REAL(8), PARAMETER :: small = 1d-6
    REAL(8) :: k0, a, mu, nu, fac
    REAL(8) :: cosmu, sinmu, cosnu2, cotnu
    REAL(8) :: dlamdx, dlamdy, dphidx, dphidy
 
    k0  = cos(half*c0*d2r)**2
    mu  = (lam-lam0)*d2r
    a   = sign(one,real(ihem,8))
    nu  = pio4 - a*half*phi*d2r
    nu  = sign(max(small,abs(nu)),nu)
    fac = r2d*half/rearth/k0
 
    cosmu  = cos(mu)
    sinmu  = sin(mu)
    cosnu2 = cos(nu)**2
    cotnu  = one/tan(nu)
 
    dlamdx =        fac*cotnu*cosmu
    dlamdy =      a*fac*cotnu*sinmu
    dphidx = -a*two*fac*cosnu2*sinmu
    dphidy =    two*fac*cosnu2*cosmu
 
    dlamdp = dxdp*dlamdx + dydp*dlamdy
    dphidp = dxdp*dphidx + dydp*dphidy
 
  END SUBROUTINE spddp
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE spddq( LAM0, C0, IHEM, LAM, PHI, DXDQ, DYDQ, &
       DLAMDQ, DPHIDQ )
    !     *** INTERNAL SUBROUTINE ***
    !     Routine to compute polar stereographic transformation of
    !     grid derivatives dx/dq & dy/dq to dlam/dq & dphi/dq.
    !
    !     mu = lam - lam0
    !     nu = pi/4 - alpha*phi/2
    !     k0 = cos(c0/2)**2
    !
    !     dlam/dx = (     1/(2*R*k0)) * cot(nu)   * cos(mu)
    !     dlam/dy = ( alpha/(2*R*k0)) * cot(nu)   * sin(mu)
    !     dphi/dx = (-alpha/(  R*k0)) * cos(nu)^2 * sin(mu)
    !     dphi/dy = (     1/(  R*k0)) * cos(nu)^2 * cos(mu)
    !
    !     dlam/dp = dx/dp*dlam/dx + dy/dp*dlam/dy
    !     dphi/dp = dx/dp*dphi/dx + dy/dp*dphi/dy
    !     dlam/dq = dx/dq*dlam/dx + dy/dq*dlam/dy
    !     dphi/dq = dx/dq*dphi/dx + dy/dq*dphi/dy
    !
    REAL(8),INTENT(IN) :: lam0, c0
    INTEGER,INTENT(IN) :: ihem
    REAL(8),INTENT(IN) :: lam, phi
    REAL(8),INTENT(IN) :: dxdq, dydq
    REAL(8),INTENT(OUT):: dlamdq, dphidq
 
    !     Local parameters
    REAL(8), PARAMETER :: small = 1d-6
    REAL(8) :: k0, a, mu, nu, fac
    REAL(8) :: cosmu, sinmu, cosnu2, cotnu
    REAL(8) :: dlamdx, dlamdy, dphidx, dphidy
 
    k0  = cos(half*c0*d2r)**2
    mu  = (lam-lam0)*d2r
    a   = sign(one,real(ihem,8))
    nu  = pio4 - a*half*phi*d2r
    nu  = sign(max(small,abs(nu)),nu)
    fac = r2d*half/rearth/k0
 
    cosmu  = cos(mu)
    sinmu  = sin(mu)
    cosnu2 = cos(nu)**2
    cotnu  = one/tan(nu)
 
    dlamdx =        fac*cotnu*cosmu
    dlamdy =      a*fac*cotnu*sinmu
    dphidx = -a*two*fac*cosnu2*sinmu
    dphidy =    two*fac*cosnu2*cosmu
 
    dlamdq = dxdq*dlamdx + dydq*dlamdy
    dphidq = dxdq*dphidx + dydq*dphidy
 
  END SUBROUTINE spddq
  !/
  !/ ------------------------------------------------------------------- /
  !/
#undef  DFDPQ_SINGLE_POINT_WIDE_CHANNEL_ERROR
#undef  DFDPQ_SINGLE_POINT_WIDE_CHANNEL_WARNING
  SUBROUTINE dfdpq( N, K, C, IJG, ICLO, &
       PTILED, QTILED, &
       PRANGE, QRANGE, &
       LB, UB, P, Q, &
       F4, F8, DFDP, DFDQ, &
       G4, G8, DGDP, DGDQ, &
       H4, H8, DHDP, DHDQ, &
       NSDP, ISDP, JSDP, CSDP, &
       NSDQ, ISDQ, JSDQ, CSDQ, &
       MASK, RC )
    !     *** INTERNAL SUBROUTINE ***
    INTEGER, INTENT(IN)   :: n
    INTEGER, INTENT(IN)   :: k(0:n,0:n,1:n)
    REAL(8), INTENT(IN)   :: c(0:n,0:n,1:n)
    LOGICAL, INTENT(IN)   :: ijg
    INTEGER, INTENT(IN)   :: iclo
    LOGICAL, INTENT(IN)   :: ptiled, qtiled
    INTEGER, INTENT(IN)   :: prange(2), qrange(2)
    INTEGER, INTENT(IN)   :: lb(2), ub(2)
    INTEGER, INTENT(IN)   :: p, q
    REAL(4), INTENT(IN),  OPTIONAL :: f4(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(IN),  OPTIONAL :: f8(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(OUT), OPTIONAL :: dfdp, dfdq
    REAL(4), INTENT(IN),  OPTIONAL :: g4(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(IN),  OPTIONAL :: g8(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(OUT), OPTIONAL :: dgdp, dgdq
    REAL(4), INTENT(IN),  OPTIONAL :: h4(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(IN),  OPTIONAL :: h8(lb(1):ub(1),lb(2):ub(2))
    REAL(8), INTENT(OUT), OPTIONAL :: dhdp, dhdq
    INTEGER, INTENT(OUT), OPTIONAL :: nsdp
    INTEGER, POINTER,     OPTIONAL :: isdp(:), jsdp(:)
    REAL(8), POINTER,     OPTIONAL :: csdp(:)
    INTEGER, INTENT(OUT), OPTIONAL :: nsdq
    INTEGER, POINTER,     OPTIONAL :: isdq(:), jsdq(:)
    REAL(8), POINTER,     OPTIONAL :: csdq(:)
    LOGICAL, INTENT(IN),  OPTIONAL :: mask(lb(1):ub(1),lb(2):ub(2))
    INTEGER, INTENT(OUT), OPTIONAL :: rc
 
    !     Local parameters
    INTEGER, PARAMETER :: m = 1 ! order of derivative
    LOGICAL, PARAMETER :: debug = .false.
    CHARACTER(64) :: fstr
    LOGICAL :: comp_m, comp_f, comp_g, comp_h, type_r4
    LOGICAL :: comp_cp, comp_cq
    INTEGER :: np, nq, lbp, lbq, ubp, ubq, p0, q0
    INTEGER :: istat=0, i, j, l, ii, jj, ni, nj, ii0, iin, jj0, jjn
    INTEGER :: kp(0:n), kq(0:n)
    LOGICAL :: mp(0:n), mq(0:n)
    REAL(8) :: fp(0:n), fq(0:n)
    REAL(8) :: gp(0:n), gq(0:n)
    REAL(8) :: hp(0:n), hq(0:n)
    INTEGER :: ip(0:n), iq(0:n)
    INTEGER :: jp(0:n), jq(0:n)
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Check and setup inputs
    !
    IF ( PRESENT(rc) ) rc = 0
 
    comp_f = ( PRESENT(f4) .OR. PRESENT(f8) ) .AND. &
         PRESENT(dfdp) .AND. PRESENT(dfdq)
    comp_g = ( PRESENT(g4) .OR. PRESENT(g8) ) .AND. &
         PRESENT(dgdp) .AND. PRESENT(dgdq)
    comp_h = ( PRESENT(h4) .OR. PRESENT(h8) ) .AND. &
         PRESENT(dhdp) .AND. PRESENT(dhdq)
    comp_cp = PRESENT(nsdp) .AND. PRESENT(isdp) .AND. &
         PRESENT(jsdp) .AND. PRESENT(csdp)
    comp_cq = PRESENT(nsdq) .AND. PRESENT(isdq) .AND. &
         PRESENT(jsdq) .AND. PRESENT(csdq)
    IF ( .NOT.comp_f.AND..NOT.comp_g.AND..NOT.comp_h.AND. &
         .NOT.comp_cp.AND..NOT.comp_cq ) RETURN
 
    IF ( comp_f ) THEN
      type_r4 = PRESENT(f4)
    ELSE IF ( comp_g ) THEN
      type_r4 = PRESENT(g4)
    ELSE IF ( comp_h ) THEN
      type_r4 = PRESENT(h4)
    END IF
 
    np = prange(2) - prange(1) + 1
    nq = qrange(2) - qrange(1) + 1
 
    IF ( ijg ) THEN
      lbp = lb(1); lbq = lb(2)
      ubp = ub(1); ubq = ub(2)
    ELSE
      lbp = lb(2); lbq = lb(1)
      ubp = ub(2); ubq = ub(1)
    END IF
 
    IF ( p.LT.lbp .OR. p.GT.ubp .OR. q.LT.lbq .OR. q.GT.ubq ) THEN
      WRITE(0,'(/1A,/1A,1L2,5I6,/1A,1L2,5I6/)') 'DFDPQ ERROR -- '// &
           'input index coordinates outside input array bounds', &
           'DFDPQ ERROR -- PTILED,PRANGE,P,LBP,UBP:',ptiled,prange,p,lbp,ubp, &
           'DFDPQ ERROR -- QTILED,QRANGE,Q,LBQ,UBQ:',qtiled,qrange,q,lbq,ubq
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    p0 = p
    q0 = q
    IF ( mod(iclo,2).EQ.0 ) &
         p0 = prange(1) + mod(np - 1 + mod(p0 - prange(1) + 1, np), np)
    IF ( mod(iclo,3).EQ.0 ) &
         q0 = qrange(1) + mod(nq - 1 + mod(q0 - qrange(1) + 1, nq), nq)
    IF ( iclo.EQ.iclo_trpl .AND. q0.GT.qrange(2) ) THEN
      p0 = prange(2) + prange(1) - p0
      q0 = 2*qrange(2) - q0 + 1
    END IF
    IF ( p0.LT.prange(1) .OR. p0.GT.prange(2) .OR. &
         q0.LT.qrange(1) .OR. q0.GT.qrange(2) ) THEN
      WRITE(0,'(/1A,/1A,4I6,/1A,4I6/)') 'DFDPQ ERROR -- '// &
           'shifted input index coordinates outside allowed range', &
           'DFDPQ ERROR -- PRANGE,P,P0:',prange,p,p0, &
           'DFDPQ ERROR -- QRANGE,Q,Q0:',qrange,q,q0
      istat = 1
      IF ( PRESENT(rc) ) THEN
        rc = istat
        RETURN
      ELSE
        CALL extcde (istat)
      END IF
    END IF
 
    comp_m = PRESENT(mask)
    IF ( comp_m ) THEN
      IF ( ijg ) THEN
        IF ( mask(p0,q0) ) RETURN
      ELSE
        IF ( mask(q0,p0) ) RETURN
      END IF
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 2.  Compute DF/DP
    !
    IF ( comp_f.OR.comp_g.OR.comp_h.OR.comp_cp ) THEN
 
      IF ( mod(iclo,2).EQ.0 ) THEN
        i = n/2
      ELSE
        IF (p0-prange(1).LT.n/2) THEN
          i = p0 - prange(1)
        ELSE IF (prange(2)-p0.LT.n/2) THEN
          i = n + p0 - prange(2)
        ELSE
          i = n/2
        END IF
      END IF
 
      kp(:) = p + k(:,i,n)
      kq(:) = q
      IF ( .NOT.ptiled ) THEN
        IF ( mod(iclo,2).EQ.0 ) THEN
          kp = prange(1) + mod(np - 1 + mod(kp - prange(1) + 1, np), np)
        END IF
      END IF
 
      IF ( minval(kp).LT.lbp .OR. maxval(kp).GT.ubp .OR. &
           minval(kq).LT.lbq .OR. maxval(kq).GT.ubq ) THEN
        WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DFDPQ ERROR -- '// &
             'stencil index coordinates outside array bounds', &
             'DFDPQ ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', &
             ptiled,prange,p,p0,lbp,ubp,minval(kp),maxval(kp), &
             'DFDPQ ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', &
             qtiled,qrange,q,q0,lbq,ubq,minval(kq),maxval(kq)
        istat = 1
        IF ( PRESENT(rc) ) THEN
          rc = istat
          RETURN
        ELSE
          CALL extcde (istat)
        END IF
      END IF
 
      IF ( comp_cp ) THEN
        ip(:) = p0 + k(:,i,n)
        jp(:) = q0
        IF ( mod(iclo,2).EQ.0 ) THEN
          ip = prange(1) + mod(np - 1 + mod(ip - prange(1) + 1, np), np)
        END IF
      END IF
 
      DO l = 0, n
        IF ( ijg ) THEN
          IF ( comp_m ) mp(l) = mask(kp(l),kq(l))
          IF ( type_r4 ) THEN
            IF ( comp_f ) fp(l) = f4(kp(l),kq(l))
            IF ( comp_g ) gp(l) = g4(kp(l),kq(l))
            IF ( comp_h ) hp(l) = h4(kp(l),kq(l))
          ELSE
            IF ( comp_f ) fp(l) = f8(kp(l),kq(l))
            IF ( comp_g ) gp(l) = g8(kp(l),kq(l))
            IF ( comp_h ) hp(l) = h8(kp(l),kq(l))
          END IF
        ELSE
          IF ( comp_m ) mp(l) = mask(kq(l),kp(l))
          IF ( type_r4 ) THEN
            IF ( comp_f ) fp(l) = f4(kq(l),kp(l))
            IF ( comp_g ) gp(l) = g4(kq(l),kp(l))
            IF ( comp_h ) hp(l) = h4(kq(l),kp(l))
          ELSE
            IF ( comp_f ) fp(l) = f8(kq(l),kp(l))
            IF ( comp_g ) gp(l) = g8(kq(l),kp(l))
            IF ( comp_h ) hp(l) = h8(kq(l),kp(l))
          END IF
        END IF
      END DO
 
      ii = i
      ni = n
      ii0 = 0
      iin = n
      IF ( comp_m ) THEN
        DO l = i-1, 0, -1
          IF ( mp(l) ) THEN
            mp(0:l) = .true.
            EXIT
          END IF
        END DO
        DO l = i+1, n
          IF ( mp(l) ) THEN
            mp(l:n) = .true.
            EXIT
          END IF
        END DO
        ii = count(.NOT.mp(0:i)) - 1
        ni = count(.NOT.mp(0:n)) - 1
        ii0 = i - ii
        iin = ii0 + ni
      END IF
#ifdef DFDPQ_SINGLE_POINT_WIDE_CHANNEL_ERROR
      IF ( ni.LE.0 ) THEN
        WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ ERROR -- ', &
             'DFDP -- single point wide channel not allowed',p,q,p0,q0
        istat = 1
        IF ( PRESENT(rc) ) THEN
          rc = istat
          RETURN
        ELSE
          CALL extcde (istat)
        END IF
      END IF
#endif
 
      IF ( ni.GT.0 ) THEN
        IF ( comp_f ) dfdp = dot_product(c(0:ni,ii,ni),fp(ii0:iin))
        IF ( comp_g ) dgdp = dot_product(c(0:ni,ii,ni),gp(ii0:iin))
        IF ( comp_h ) dhdp = dot_product(c(0:ni,ii,ni),hp(ii0:iin))
        IF ( comp_cp ) THEN
          IF ( ASSOCIATED(isdp) ) DEALLOCATE(isdp)
          IF ( ASSOCIATED(jsdp) ) DEALLOCATE(jsdp)
          IF ( ASSOCIATED(csdp) ) DEALLOCATE(csdp)
          nsdp = ni+1
          ALLOCATE(isdp(nsdp),jsdp(nsdp),csdp(nsdp))
          isdp(1:nsdp) = ip(ii0:iin)
          jsdp(1:nsdp) = jp(ii0:iin)
          csdp(1:nsdp) = c(0:ni,ii,ni)
        END IF
        IF ( debug .AND. comp_f ) THEN
          WRITE(fstr,'(A,I0,A,I0,A,I0,A)') '(/1A,8I6,E16.8,/1A,',&
               ni+1,'I16,/1A,',ni+1,'E16.8,/1A,',ni+1,'E16.8)'
          WRITE(*,trim(fstr)) &
               'DFDPQ -- DFDP -- P,Q,P0,Q0,NI,II,II0,IIN,DFDP:',&
               p,q,p0,q0,ni,ii,ii0,iin,dfdp, &
               'DFDPQ -- DFDP --  K:', k(0:ni,ii,ni), &
               'DFDPQ -- DFDP --  C:', c(0:ni,ii,ni), &
               'DFDPQ -- DFDP -- FP:', fp(ii0:iin)
        END IF
      ELSE
#ifdef DFDPQ_SINGLE_POINT_WIDE_CHANNEL_WARNING
        WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ WARNING -- ', &
             'single point wide channel, DFDP set to zero:',p,q,p0,q0
#endif
        IF ( comp_f ) dfdp = zero
        IF ( comp_g ) dgdp = zero
        IF ( comp_h ) dhdp = zero
        IF ( comp_cp ) nsdp = 0
      END IF
 
    END IF
    !
    ! -------------------------------------------------------------------- /
    ! 3.  Compute DF/DQ
    !
    IF ( comp_f.OR.comp_g.OR.comp_h.OR.comp_cq ) THEN
 
      IF ( mod(iclo,3).EQ.0 ) THEN
        j = n/2
      ELSE IF ( iclo.EQ.iclo_trpl ) THEN
        IF (q0-qrange(1).LT.n/2) THEN
          j = q0 - qrange(1)
        ELSE
          j = n/2
        END IF
      ELSE
        IF (q0-qrange(1).LT.n/2) THEN
          j = q0 - qrange(1)
        ELSE IF (qrange(2)-q0.LT.n/2) THEN
          j = n + q0 - qrange(2)
        ELSE
          j = n/2
        END IF
      END IF
 
      kp(:) = p
      kq(:) = q + k(:,j,n)
      IF ( .NOT.qtiled ) THEN
        IF ( mod(iclo,3).EQ.0 ) THEN
          kq = qrange(1) + mod(nq - 1 + mod(kq - qrange(1) + 1, nq), nq)
        END IF
        IF ( iclo.EQ.iclo_trpl .AND. .NOT.ptiled ) THEN
          WHERE ( kq.GT.qrange(2) )
            kp = prange(2) + prange(1) - kp
            kq = 2*qrange(2) - kq + 1
          END WHERE
        END IF
      END IF
 
      IF ( minval(kp).LT.lbp .OR. maxval(kp).GT.ubp .OR. &
           minval(kq).LT.lbq .OR. maxval(kq).GT.ubq ) THEN
        WRITE(0,'(/1A,/1A,1L2,8I6,/1A,1L2,8I6/)') 'DFDPQ ERROR -- '// &
             'stencil index coordinates outside array bounds', &
             'DFDPQ ERROR -- PTILED,PRANGE,P,P0,LBP,UBP,PMIN,PMAX:', &
             ptiled,prange,p,p0,lbp,ubp,minval(kp),maxval(kp), &
             'DFDPQ ERROR -- QTILED,QRANGE,Q,Q0,LBQ,UBQ,QMIN,QMAX:', &
             qtiled,qrange,q,q0,lbq,ubq,minval(kq),maxval(kq)
        istat = 1
        IF ( PRESENT(rc) ) THEN
          rc = istat
          RETURN
        ELSE
          CALL extcde (istat)
        END IF
      END IF
 
      IF ( comp_cq ) THEN
        iq(:) = p0
        jq(:) = q0 + k(:,j,n)
        IF ( mod(iclo,3).EQ.0 ) THEN
          jq = qrange(1) + mod(nq - 1 + mod(jq - qrange(1) + 1, nq), nq)
        END IF
        IF ( iclo.EQ.iclo_trpl ) THEN
          WHERE ( jq.GT.qrange(2) )
            iq = prange(2) + prange(1) - iq
            jq = 2*qrange(2) - jq + 1
          END WHERE
        END IF
      END IF
 
      DO l = 0, n
        IF ( ijg ) THEN
          IF ( comp_m ) mq(l) = mask(kp(l),kq(l))
          IF ( type_r4 ) THEN
            IF ( comp_f ) fq(l) = f4(kp(l),kq(l))
            IF ( comp_g ) gq(l) = g4(kp(l),kq(l))
            IF ( comp_h ) hq(l) = h4(kp(l),kq(l))
          ELSE
            IF ( comp_f ) fq(l) = f8(kp(l),kq(l))
            IF ( comp_g ) gq(l) = g8(kp(l),kq(l))
            IF ( comp_h ) hq(l) = h8(kp(l),kq(l))
          END IF
        ELSE
          IF ( comp_m ) mq(l) = mask(kq(l),kp(l))
          IF ( type_r4 ) THEN
            IF ( comp_f ) fq(l) = f4(kq(l),kp(l))
            IF ( comp_g ) gq(l) = g4(kq(l),kp(l))
            IF ( comp_h ) hq(l) = h4(kq(l),kp(l))
          ELSE
            IF ( comp_f ) fq(l) = f8(kq(l),kp(l))
            IF ( comp_g ) gq(l) = g8(kq(l),kp(l))
            IF ( comp_h ) hq(l) = h8(kq(l),kp(l))
          END IF
        END IF
      END DO
 
      jj = j
      nj = n
      jj0 = 0
      jjn = n
      IF ( comp_m ) THEN
        DO l = j-1, 0, -1
          IF ( mq(l) ) THEN
            mq(0:l) = .true.
            EXIT
          END IF
        END DO
        DO l = j+1, n
          IF ( mq(l) ) THEN
            mq(l:n) = .true.
            EXIT
          END IF
        END DO
        jj = count(.NOT.mq(0:j)) - 1
        nj = count(.NOT.mq(0:n)) - 1
        jj0 = j - jj
        jjn = jj0 + nj
      END IF
#ifdef DFDPQ_SINGLE_POINT_WIDE_CHANNEL_ERROR
      IF ( nj.LE.0 ) THEN
        WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ ERROR -- ', &
             'DFDQ -- single point wide channel not allowed',p,q,p0,q0
        istat = 1
        IF ( PRESENT(rc) ) THEN
          rc = istat
          RETURN
        ELSE
          CALL extcde (istat)
        END IF
      END IF
#endif
 
      IF ( nj.GT.0 ) THEN
        IF ( comp_f ) dfdq = dot_product(c(0:nj,jj,nj),fq(jj0:jjn))
        IF ( comp_g ) dgdq = dot_product(c(0:nj,jj,nj),gq(jj0:jjn))
        IF ( comp_h ) dhdq = dot_product(c(0:nj,jj,nj),hq(jj0:jjn))
        IF ( comp_cq ) THEN
          IF ( ASSOCIATED(isdq) ) DEALLOCATE(isdq)
          IF ( ASSOCIATED(jsdq) ) DEALLOCATE(jsdq)
          IF ( ASSOCIATED(csdq) ) DEALLOCATE(csdq)
          nsdq = nj+1
          ALLOCATE(isdq(nsdq),jsdq(nsdq),csdq(nsdq))
          isdq(1:nsdq) = iq(jj0:jjn)
          jsdq(1:nsdq) = jq(jj0:jjn)
          csdq(1:nsdq) = c(0:nj,jj,nj)
        END IF
        IF ( debug .AND. comp_f ) THEN
          WRITE(fstr,'(A,I0,A,I0,A,I0,A)') '(/1A,8I6,E16.8,/1A,',&
               nj+1,'I16,/1A,',nj+1,'E16.8,/1A,',nj+1,'E16.8)'
          WRITE(*,trim(fstr)) &
               'DFDPQ -- DFDQ -- P,Q,P0,Q0,NJ,JJ,JJ0,JJN,DFDQ:',&
               p,q,p0,q0,nj,jj,jj0,jjn,dfdq, &
               'DFDPQ -- DFDQ --  K:', k(0:nj,jj,nj), &
               'DFDPQ -- DFDQ --  C:', c(0:nj,jj,nj), &
               'DFDPQ -- DFDQ -- FQ:', fq(jj0:jjn)
        END IF
      ELSE
#ifdef DFDPQ_SINGLE_POINT_WIDE_CHANNEL_WARNING
        WRITE(0,'(/1A,1A,4I6/)') 'DFDPQ WARNING -- ', &
             'single point wide channel, DFDQ set to zero:',p,q,p0,q0
#endif
        IF ( comp_f ) dfdq = zero
        IF ( comp_g ) dgdq = zero
        IF ( comp_h ) dhdq = zero
        IF ( comp_cq ) nsdq = 0
      END IF
 
    END IF
 
  END SUBROUTINE dfdpq
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE get_fdw2( N, M, K, C )
    !     *** INTERNAL SUBROUTINE ***
    INTEGER,INTENT(IN) :: n, m
    INTEGER,INTENT(OUT):: k(0:n,0:n)
    REAL(8),INTENT(OUT):: c(0:n,0:n)
    INTEGER :: i, j
    REAL(8) :: a(0:n), b(0:n,0:m)
 
    DO i = 0, n
      DO j = 0, n
        k(j,i) = j-i
        a(j) = k(j,i)
      END DO
      CALL w3fdwt( n, n, m, zero, a, b )
      c(0:n,i) = b(0:n,m)
      !WRITE(0,'(A,I1,2X,11I16)') 'I=',I,K(0:N,I)
      !WRITE(0,'(5X,11E16.8)') C(0:N,I)
    END DO
 
  END SUBROUTINE get_fdw2
  !/
  !/ ------------------------------------------------------------------- /
  !/
  SUBROUTINE get_fdw3( N, M, K, C )
    !     *** INTERNAL SUBROUTINE ***
    INTEGER,INTENT(IN) :: n, m
    INTEGER,INTENT(OUT):: k(0:n,0:n,1:n)
    REAL(8),INTENT(OUT):: c(0:n,0:n,1:n)
    INTEGER :: l, i, j
    REAL(8) :: a(0:n), b(0:n,0:m)
 
    DO l = 1, n
      !WRITE(0,'(A,I1,2X,11A)') 'L=',L,('----------------',I=0,L)
      DO i = 0, l
        DO j = 0, l
          k(j,i,l) = j-i
          a(j) = k(j,i,l)
        END DO
        CALL w3fdwt( l, n, m, zero, a, b )
        c(0:l,i,l) = b(0:l,m)
        !WRITE(0,'(A,I1,2X,11I16)') 'I=',I,K(0:L,I,L)
        !WRITE(0,'(5X,11E16.8)') C(0:L,I,L)
      END DO
    END DO
 
  END SUBROUTINE get_fdw3
  !/
  !/ ------------------------------------------------------------------- /
  !/
  !/
  !/ End Internal Support Routines ===================================== /
  !/
  !/
 
 
 
 
 
 
 
 
#ifndef ENABLE_WW3
  !/
  !/ Local routines for use outside of WW3 ============================= /
  !/
  SUBROUTINE extcde(IEXIT)
#ifdef ENABLE_MPI
    include "mpif.h"
#endif
    INTEGER, INTENT(IN) :: iexit
#ifdef ENABLE_MPI
    INTEGER             :: ierr_mpi
    LOGICAL             :: run
    CALL mpi_initialized ( run, ierr_mpi )
    IF ( run ) THEN
      CALL mpi_abort ( mpi_comm_world, iexit, ierr_mpi )
    END IF
#endif
    CALL exit(iexit)
  END SUBROUTINE extcde
  !/
  !/ End local routines for use outside of WW3 ========================= /
  !/
#endif
 
 
 
 
 
 
 
 
  !/
  !/ End of module W3GSRUMD ============================================ /
  !/
END MODULE w3gsrumd