# 1 "../axis_utils/axis_utils.F90"
!***********************************************************************
!* GNU Lesser General Public License
!*
!* This file is part of the GFDL Flexible Modeling System (FMS).
!*
!* FMS is free software: you can redistribute it and/or modify it under
!* the terms of the GNU Lesser General Public License as published by
!* the Free Software Foundation, either version 3 of the License, or (at
!* your option) any later version.
!*
!* FMS is distributed in the hope that it will be useful, but WITHOUT
!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
!* for more details.
!*
!* You should have received a copy of the GNU Lesser General Public
!* License along with FMS. If not, see .
!***********************************************************************
module axis_utils_mod
!
!M.J. Harrison
!
!Bruce Wyman
!
!
! A set of utilities for manipulating axes and extracting axis
! attributes
!
!
!
! subroutine get_axis_cart(axis,cart) : Returns X,Y,Z or T cartesian attribute
! subroutine get_axis_bounds(axis,axis_bound,axes) : Return axis_bound either from an array of
! available axes, or defined based on axis mid-points
! function get_axis_modulo : Returns true if axis has the modulo attribute
! function get_axis_fold : Returns is axis is folded at a boundary (non-standard meta-data)
! function lon_in_range : Returns lon_strt <= longitude <= lon_strt+360
! subroutine tranlon : Returns monotonic array of longitudes s.t., lon_strt <= lon(:) <= lon_strt+360.
! subroutine nearest_index : Return index of nearest point along axis
!
!
!
use mpp_io_mod, only: axistype, atttype, default_axis, default_att, &
mpp_get_atts, mpp_get_axis_data, mpp_modify_meta, &
mpp_get_att_name, mpp_get_att_type, mpp_get_att_char, &
mpp_get_att_length, mpp_get_axis_bounds
use mpp_mod, only: mpp_error, FATAL, stdout
use fms_mod, only: lowercase, string_array_index, fms_error_handler
implicit none
# 1 "/apps/prod/hpc-stack/intel-19.1.3.304/cray-mpich-8.1.4/netcdf/4.7.4/include/netcdf.inc" 1
! NetCDF-3.
!
! netcdf version 3 fortran interface:
!
!
! external netcdf data types:
!
integer nf_byte
integer nf_int1
integer nf_char
integer nf_short
integer nf_int2
integer nf_int
integer nf_float
integer nf_real
integer nf_double
integer nf_ubyte
integer nf_ushort
integer nf_uint
integer nf_int64
integer nf_uint64
parameter (nf_byte = 1)
parameter (nf_int1 = nf_byte)
parameter (nf_char = 2)
parameter (nf_short = 3)
parameter (nf_int2 = nf_short)
parameter (nf_int = 4)
parameter (nf_float = 5)
parameter (nf_real = nf_float)
parameter (nf_double = 6)
parameter (nf_ubyte = 7)
parameter (nf_ushort = 8)
parameter (nf_uint = 9)
parameter (nf_int64 = 10)
parameter (nf_uint64 = 11)
!
! default fill values:
!
integer nf_fill_byte
integer nf_fill_int1
integer nf_fill_char
integer nf_fill_short
integer nf_fill_int2
integer nf_fill_int
real nf_fill_float
real nf_fill_real
doubleprecision nf_fill_double
parameter (nf_fill_byte = -127)
parameter (nf_fill_int1 = nf_fill_byte)
parameter (nf_fill_char = 0)
parameter (nf_fill_short = -32767)
parameter (nf_fill_int2 = nf_fill_short)
parameter (nf_fill_int = -2147483647)
parameter (nf_fill_float = 9.9692099683868690e+36)
parameter (nf_fill_real = nf_fill_float)
parameter (nf_fill_double = 9.9692099683868690d+36)
!
! mode flags for opening and creating a netcdf dataset:
!
integer nf_nowrite
integer nf_write
integer nf_clobber
integer nf_noclobber
integer nf_fill
integer nf_nofill
integer nf_lock
integer nf_share
integer nf_64bit_offset
integer nf_64bit_data
integer nf_cdf5
integer nf_sizehint_default
integer nf_align_chunk
integer nf_format_classic
integer nf_format_64bit
integer nf_format_64bit_offset
integer nf_format_64bit_data
integer nf_format_cdf5
integer nf_diskless
integer nf_mmap
parameter (nf_nowrite = 0)
parameter (nf_write = 1)
parameter (nf_clobber = 0)
parameter (nf_noclobber = 4)
parameter (nf_fill = 0)
parameter (nf_nofill = 256)
parameter (nf_lock = 1024)
parameter (nf_share = 2048)
parameter (nf_64bit_offset = 512)
parameter (nf_64bit_data = 32)
parameter (nf_cdf5 = nf_64bit_data)
parameter (nf_sizehint_default = 0)
parameter (nf_align_chunk = -1)
parameter (nf_format_classic = 1)
parameter (nf_format_64bit = 2)
parameter (nf_format_64bit_offset = nf_format_64bit)
parameter (nf_format_64bit_data = 5)
parameter (nf_format_cdf5 = nf_format_64bit_data)
parameter (nf_diskless = 8)
parameter (nf_mmap = 16)
!
! size argument for defining an unlimited dimension:
!
integer nf_unlimited
parameter (nf_unlimited = 0)
!
! global attribute id:
!
integer nf_global
parameter (nf_global = 0)
!
! implementation limits:
!
integer nf_max_dims
integer nf_max_attrs
integer nf_max_vars
integer nf_max_name
integer nf_max_var_dims
parameter (nf_max_dims = 1024)
parameter (nf_max_attrs = 8192)
parameter (nf_max_vars = 8192)
parameter (nf_max_name = 256)
parameter (nf_max_var_dims = nf_max_dims)
!
! error codes:
!
integer nf_noerr
integer nf_ebadid
integer nf_eexist
integer nf_einval
integer nf_eperm
integer nf_enotindefine
integer nf_eindefine
integer nf_einvalcoords
integer nf_emaxdims
integer nf_enameinuse
integer nf_enotatt
integer nf_emaxatts
integer nf_ebadtype
integer nf_ebaddim
integer nf_eunlimpos
integer nf_emaxvars
integer nf_enotvar
integer nf_eglobal
integer nf_enotnc
integer nf_ests
integer nf_emaxname
integer nf_eunlimit
integer nf_enorecvars
integer nf_echar
integer nf_eedge
integer nf_estride
integer nf_ebadname
integer nf_erange
integer nf_enomem
integer nf_evarsize
integer nf_edimsize
integer nf_etrunc
parameter (nf_noerr = 0)
parameter (nf_ebadid = -33)
parameter (nf_eexist = -35)
parameter (nf_einval = -36)
parameter (nf_eperm = -37)
parameter (nf_enotindefine = -38)
parameter (nf_eindefine = -39)
parameter (nf_einvalcoords = -40)
parameter (nf_emaxdims = -41)
parameter (nf_enameinuse = -42)
parameter (nf_enotatt = -43)
parameter (nf_emaxatts = -44)
parameter (nf_ebadtype = -45)
parameter (nf_ebaddim = -46)
parameter (nf_eunlimpos = -47)
parameter (nf_emaxvars = -48)
parameter (nf_enotvar = -49)
parameter (nf_eglobal = -50)
parameter (nf_enotnc = -51)
parameter (nf_ests = -52)
parameter (nf_emaxname = -53)
parameter (nf_eunlimit = -54)
parameter (nf_enorecvars = -55)
parameter (nf_echar = -56)
parameter (nf_eedge = -57)
parameter (nf_estride = -58)
parameter (nf_ebadname = -59)
parameter (nf_erange = -60)
parameter (nf_enomem = -61)
parameter (nf_evarsize = -62)
parameter (nf_edimsize = -63)
parameter (nf_etrunc = -64)
!
! error handling modes:
!
integer nf_fatal
integer nf_verbose
parameter (nf_fatal = 1)
parameter (nf_verbose = 2)
!
! miscellaneous routines:
!
character*80 nf_inq_libvers
external nf_inq_libvers
character*80 nf_strerror
! (integer ncerr)
external nf_strerror
logical nf_issyserr
! (integer ncerr)
external nf_issyserr
!
! control routines:
!
integer nf_inq_base_pe
! (integer ncid,
! integer pe)
external nf_inq_base_pe
integer nf_set_base_pe
! (integer ncid,
! integer pe)
external nf_set_base_pe
integer nf_create
! (character*(*) path,
! integer cmode,
! integer ncid)
external nf_create
integer nf__create
! (character*(*) path,
! integer cmode,
! integer initialsz,
! integer chunksizehint,
! integer ncid)
external nf__create
integer nf__create_mp
! (character*(*) path,
! integer cmode,
! integer initialsz,
! integer basepe,
! integer chunksizehint,
! integer ncid)
external nf__create_mp
integer nf_open
! (character*(*) path,
! integer mode,
! integer ncid)
external nf_open
integer nf__open
! (character*(*) path,
! integer mode,
! integer chunksizehint,
! integer ncid)
external nf__open
integer nf__open_mp
! (character*(*) path,
! integer mode,
! integer basepe,
! integer chunksizehint,
! integer ncid)
external nf__open_mp
integer nf_set_fill
! (integer ncid,
! integer fillmode,
! integer old_mode)
external nf_set_fill
integer nf_set_default_format
! (integer format,
! integer old_format)
external nf_set_default_format
integer nf_redef
! (integer ncid)
external nf_redef
integer nf_enddef
! (integer ncid)
external nf_enddef
integer nf__enddef
! (integer ncid,
! integer h_minfree,
! integer v_align,
! integer v_minfree,
! integer r_align)
external nf__enddef
integer nf_sync
! (integer ncid)
external nf_sync
integer nf_abort
! (integer ncid)
external nf_abort
integer nf_close
! (integer ncid)
external nf_close
integer nf_delete
! (character*(*) ncid)
external nf_delete
!
! general inquiry routines:
!
integer nf_inq
! (integer ncid,
! integer ndims,
! integer nvars,
! integer ngatts,
! integer unlimdimid)
external nf_inq
! new inquire path
integer nf_inq_path
external nf_inq_path
integer nf_inq_ndims
! (integer ncid,
! integer ndims)
external nf_inq_ndims
integer nf_inq_nvars
! (integer ncid,
! integer nvars)
external nf_inq_nvars
integer nf_inq_natts
! (integer ncid,
! integer ngatts)
external nf_inq_natts
integer nf_inq_unlimdim
! (integer ncid,
! integer unlimdimid)
external nf_inq_unlimdim
integer nf_inq_format
! (integer ncid,
! integer format)
external nf_inq_format
!
! dimension routines:
!
integer nf_def_dim
! (integer ncid,
! character(*) name,
! integer len,
! integer dimid)
external nf_def_dim
integer nf_inq_dimid
! (integer ncid,
! character(*) name,
! integer dimid)
external nf_inq_dimid
integer nf_inq_dim
! (integer ncid,
! integer dimid,
! character(*) name,
! integer len)
external nf_inq_dim
integer nf_inq_dimname
! (integer ncid,
! integer dimid,
! character(*) name)
external nf_inq_dimname
integer nf_inq_dimlen
! (integer ncid,
! integer dimid,
! integer len)
external nf_inq_dimlen
integer nf_rename_dim
! (integer ncid,
! integer dimid,
! character(*) name)
external nf_rename_dim
!
! general attribute routines:
!
integer nf_inq_att
! (integer ncid,
! integer varid,
! character(*) name,
! integer xtype,
! integer len)
external nf_inq_att
integer nf_inq_attid
! (integer ncid,
! integer varid,
! character(*) name,
! integer attnum)
external nf_inq_attid
integer nf_inq_atttype
! (integer ncid,
! integer varid,
! character(*) name,
! integer xtype)
external nf_inq_atttype
integer nf_inq_attlen
! (integer ncid,
! integer varid,
! character(*) name,
! integer len)
external nf_inq_attlen
integer nf_inq_attname
! (integer ncid,
! integer varid,
! integer attnum,
! character(*) name)
external nf_inq_attname
integer nf_copy_att
! (integer ncid_in,
! integer varid_in,
! character(*) name,
! integer ncid_out,
! integer varid_out)
external nf_copy_att
integer nf_rename_att
! (integer ncid,
! integer varid,
! character(*) curname,
! character(*) newname)
external nf_rename_att
integer nf_del_att
! (integer ncid,
! integer varid,
! character(*) name)
external nf_del_att
!
! attribute put/get routines:
!
integer nf_put_att_text
! (integer ncid,
! integer varid,
! character(*) name,
! integer len,
! character(*) text)
external nf_put_att_text
integer nf_get_att_text
! (integer ncid,
! integer varid,
! character(*) name,
! character(*) text)
external nf_get_att_text
integer nf_put_att_int1
! (integer ncid,
! integer varid,
! character(*) name,
! integer xtype,
! integer len,
! nf_int1_t i1vals(1))
external nf_put_att_int1
integer nf_get_att_int1
! (integer ncid,
! integer varid,
! character(*) name,
! nf_int1_t i1vals(1))
external nf_get_att_int1
integer nf_put_att_int2
! (integer ncid,
! integer varid,
! character(*) name,
! integer xtype,
! integer len,
! nf_int2_t i2vals(1))
external nf_put_att_int2
integer nf_get_att_int2
! (integer ncid,
! integer varid,
! character(*) name,
! nf_int2_t i2vals(1))
external nf_get_att_int2
integer nf_put_att_int
! (integer ncid,
! integer varid,
! character(*) name,
! integer xtype,
! integer len,
! integer ivals(1))
external nf_put_att_int
integer nf_get_att_int
! (integer ncid,
! integer varid,
! character(*) name,
! integer ivals(1))
external nf_get_att_int
integer nf_put_att_int64
! (integer ncid,
! integer varid,
! character(*) name,
! integer xtype,
! integer len,
! nf_int8_t i8vals(1))
external nf_put_att_int64
integer nf_get_att_int64
! (integer ncid,
! integer varid,
! character(*) name,
! nf_int8_t i8vals(1))
external nf_get_att_int64
integer nf_put_att_real
! (integer ncid,
! integer varid,
! character(*) name,
! integer xtype,
! integer len,
! real rvals(1))
external nf_put_att_real
integer nf_get_att_real
! (integer ncid,
! integer varid,
! character(*) name,
! real rvals(1))
external nf_get_att_real
integer nf_put_att_double
! (integer ncid,
! integer varid,
! character(*) name,
! integer xtype,
! integer len,
! double dvals(1))
external nf_put_att_double
integer nf_get_att_double
! (integer ncid,
! integer varid,
! character(*) name,
! double dvals(1))
external nf_get_att_double
!
! general variable routines:
!
integer nf_def_var
! (integer ncid,
! character(*) name,
! integer datatype,
! integer ndims,
! integer dimids(1),
! integer varid)
external nf_def_var
integer nf_inq_var
! (integer ncid,
! integer varid,
! character(*) name,
! integer datatype,
! integer ndims,
! integer dimids(1),
! integer natts)
external nf_inq_var
integer nf_inq_varid
! (integer ncid,
! character(*) name,
! integer varid)
external nf_inq_varid
integer nf_inq_varname
! (integer ncid,
! integer varid,
! character(*) name)
external nf_inq_varname
integer nf_inq_vartype
! (integer ncid,
! integer varid,
! integer xtype)
external nf_inq_vartype
integer nf_inq_varndims
! (integer ncid,
! integer varid,
! integer ndims)
external nf_inq_varndims
integer nf_inq_vardimid
! (integer ncid,
! integer varid,
! integer dimids(1))
external nf_inq_vardimid
integer nf_inq_varnatts
! (integer ncid,
! integer varid,
! integer natts)
external nf_inq_varnatts
integer nf_rename_var
! (integer ncid,
! integer varid,
! character(*) name)
external nf_rename_var
integer nf_copy_var
! (integer ncid_in,
! integer varid,
! integer ncid_out)
external nf_copy_var
!
! entire variable put/get routines:
!
integer nf_put_var_text
! (integer ncid,
! integer varid,
! character(*) text)
external nf_put_var_text
integer nf_get_var_text
! (integer ncid,
! integer varid,
! character(*) text)
external nf_get_var_text
integer nf_put_var_int1
! (integer ncid,
! integer varid,
! nf_int1_t i1vals(1))
external nf_put_var_int1
integer nf_get_var_int1
! (integer ncid,
! integer varid,
! nf_int1_t i1vals(1))
external nf_get_var_int1
integer nf_put_var_int2
! (integer ncid,
! integer varid,
! nf_int2_t i2vals(1))
external nf_put_var_int2
integer nf_get_var_int2
! (integer ncid,
! integer varid,
! nf_int2_t i2vals(1))
external nf_get_var_int2
integer nf_put_var_int
! (integer ncid,
! integer varid,
! integer ivals(1))
external nf_put_var_int
integer nf_get_var_int
! (integer ncid,
! integer varid,
! integer ivals(1))
external nf_get_var_int
integer nf_put_var_real
! (integer ncid,
! integer varid,
! real rvals(1))
external nf_put_var_real
integer nf_get_var_real
! (integer ncid,
! integer varid,
! real rvals(1))
external nf_get_var_real
integer nf_put_var_double
! (integer ncid,
! integer varid,
! doubleprecision dvals(1))
external nf_put_var_double
integer nf_get_var_double
! (integer ncid,
! integer varid,
! doubleprecision dvals(1))
external nf_get_var_double
!
! single variable put/get routines:
!
integer nf_put_var1_text
! (integer ncid,
! integer varid,
! integer index(1),
! character*1 text)
external nf_put_var1_text
integer nf_get_var1_text
! (integer ncid,
! integer varid,
! integer index(1),
! character*1 text)
external nf_get_var1_text
integer nf_put_var1_int1
! (integer ncid,
! integer varid,
! integer index(1),
! nf_int1_t i1val)
external nf_put_var1_int1
integer nf_get_var1_int1
! (integer ncid,
! integer varid,
! integer index(1),
! nf_int1_t i1val)
external nf_get_var1_int1
integer nf_put_var1_int2
! (integer ncid,
! integer varid,
! integer index(1),
! nf_int2_t i2val)
external nf_put_var1_int2
integer nf_get_var1_int2
! (integer ncid,
! integer varid,
! integer index(1),
! nf_int2_t i2val)
external nf_get_var1_int2
integer nf_put_var1_int
! (integer ncid,
! integer varid,
! integer index(1),
! integer ival)
external nf_put_var1_int
integer nf_get_var1_int
! (integer ncid,
! integer varid,
! integer index(1),
! integer ival)
external nf_get_var1_int
integer nf_put_var1_real
! (integer ncid,
! integer varid,
! integer index(1),
! real rval)
external nf_put_var1_real
integer nf_get_var1_real
! (integer ncid,
! integer varid,
! integer index(1),
! real rval)
external nf_get_var1_real
integer nf_put_var1_double
! (integer ncid,
! integer varid,
! integer index(1),
! doubleprecision dval)
external nf_put_var1_double
integer nf_get_var1_double
! (integer ncid,
! integer varid,
! integer index(1),
! doubleprecision dval)
external nf_get_var1_double
!
! variable array put/get routines:
!
integer nf_put_vara_text
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! character(*) text)
external nf_put_vara_text
integer nf_get_vara_text
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! character(*) text)
external nf_get_vara_text
integer nf_put_vara_int1
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! nf_int1_t i1vals(1))
external nf_put_vara_int1
integer nf_get_vara_int1
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! nf_int1_t i1vals(1))
external nf_get_vara_int1
integer nf_put_vara_int2
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! nf_int2_t i2vals(1))
external nf_put_vara_int2
integer nf_get_vara_int2
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! nf_int2_t i2vals(1))
external nf_get_vara_int2
integer nf_put_vara_int
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer ivals(1))
external nf_put_vara_int
integer nf_get_vara_int
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer ivals(1))
external nf_get_vara_int
integer nf_put_vara_real
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! real rvals(1))
external nf_put_vara_real
integer nf_get_vara_real
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! real rvals(1))
external nf_get_vara_real
integer nf_put_vara_double
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! doubleprecision dvals(1))
external nf_put_vara_double
integer nf_get_vara_double
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! doubleprecision dvals(1))
external nf_get_vara_double
!
! strided variable put/get routines:
!
integer nf_put_vars_text
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! character(*) text)
external nf_put_vars_text
integer nf_get_vars_text
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! character(*) text)
external nf_get_vars_text
integer nf_put_vars_int1
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! nf_int1_t i1vals(1))
external nf_put_vars_int1
integer nf_get_vars_int1
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! nf_int1_t i1vals(1))
external nf_get_vars_int1
integer nf_put_vars_int2
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! nf_int2_t i2vals(1))
external nf_put_vars_int2
integer nf_get_vars_int2
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! nf_int2_t i2vals(1))
external nf_get_vars_int2
integer nf_put_vars_int
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer ivals(1))
external nf_put_vars_int
integer nf_get_vars_int
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer ivals(1))
external nf_get_vars_int
integer nf_put_vars_real
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! real rvals(1))
external nf_put_vars_real
integer nf_get_vars_real
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! real rvals(1))
external nf_get_vars_real
integer nf_put_vars_double
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! doubleprecision dvals(1))
external nf_put_vars_double
integer nf_get_vars_double
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! doubleprecision dvals(1))
external nf_get_vars_double
!
! mapped variable put/get routines:
!
integer nf_put_varm_text
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! character(*) text)
external nf_put_varm_text
integer nf_get_varm_text
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! character(*) text)
external nf_get_varm_text
integer nf_put_varm_int1
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! nf_int1_t i1vals(1))
external nf_put_varm_int1
integer nf_get_varm_int1
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! nf_int1_t i1vals(1))
external nf_get_varm_int1
integer nf_put_varm_int2
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! nf_int2_t i2vals(1))
external nf_put_varm_int2
integer nf_get_varm_int2
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! nf_int2_t i2vals(1))
external nf_get_varm_int2
integer nf_put_varm_int
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! integer ivals(1))
external nf_put_varm_int
integer nf_get_varm_int
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! integer ivals(1))
external nf_get_varm_int
integer nf_put_varm_real
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! real rvals(1))
external nf_put_varm_real
integer nf_get_varm_real
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! real rvals(1))
external nf_get_varm_real
integer nf_put_varm_double
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! doubleprecision dvals(1))
external nf_put_varm_double
integer nf_get_varm_double
! (integer ncid,
! integer varid,
! integer start(1),
! integer count(1),
! integer stride(1),
! integer imap(1),
! doubleprecision dvals(1))
external nf_get_varm_double
! 64-bit int functions.
integer nf_put_var1_int64
external nf_put_var1_int64
integer nf_put_vara_int64
external nf_put_vara_int64
integer nf_put_vars_int64
external nf_put_vars_int64
integer nf_put_varm_int64
external nf_put_varm_int64
integer nf_put_var_int64
external nf_put_var_int64
integer nf_get_var1_int64
external nf_get_var1_int64
integer nf_get_vara_int64
external nf_get_vara_int64
integer nf_get_vars_int64
external nf_get_vars_int64
integer nf_get_varm_int64
external nf_get_varm_int64
integer nf_get_var_int64
external nf_get_var_int64
! NetCDF-4.
! This is part of netCDF-4. Copyright 2006, UCAR, See COPYRIGHT
! file for distribution information.
! Netcdf version 4 fortran interface.
! $Id: netcdf4.inc,v 1.28 2010/05/25 13:53:02 ed Exp $
! New netCDF-4 types.
integer nf_string
integer nf_vlen
integer nf_opaque
integer nf_enum
integer nf_compound
parameter (nf_string = 12)
parameter (nf_vlen = 13)
parameter (nf_opaque = 14)
parameter (nf_enum = 15)
parameter (nf_compound = 16)
! New netCDF-4 fill values.
integer nf_fill_ubyte
integer nf_fill_ushort
! real nf_fill_uint
! real nf_fill_int64
! real nf_fill_uint64
parameter (nf_fill_ubyte = 255)
parameter (nf_fill_ushort = 65535)
! New constants.
integer nf_format_netcdf4
parameter (nf_format_netcdf4 = 3)
integer nf_format_netcdf4_classic
parameter (nf_format_netcdf4_classic = 4)
integer nf_netcdf4
parameter (nf_netcdf4 = 4096)
integer nf_classic_model
parameter (nf_classic_model = 256)
integer nf_chunk_seq
parameter (nf_chunk_seq = 0)
integer nf_chunk_sub
parameter (nf_chunk_sub = 1)
integer nf_chunk_sizes
parameter (nf_chunk_sizes = 2)
integer nf_endian_native
parameter (nf_endian_native = 0)
integer nf_endian_little
parameter (nf_endian_little = 1)
integer nf_endian_big
parameter (nf_endian_big = 2)
! For NF_DEF_VAR_CHUNKING
integer nf_chunked
parameter (nf_chunked = 0)
integer nf_contiguous
parameter (nf_contiguous = 1)
integer nf_compact
parameter (nf_compact = 2)
! For NF_DEF_VAR_FLETCHER32
integer nf_nochecksum
parameter (nf_nochecksum = 0)
integer nf_fletcher32
parameter (nf_fletcher32 = 1)
! For NF_DEF_VAR_DEFLATE
integer nf_noshuffle
parameter (nf_noshuffle = 0)
integer nf_shuffle
parameter (nf_shuffle = 1)
! For NF_DEF_VAR_SZIP
integer nf_szip_ec_option_mask
parameter (nf_szip_ec_option_mask = 4)
integer nf_szip_nn_option_mask
parameter (nf_szip_nn_option_mask = 32)
! For parallel I/O.
integer nf_mpiio
parameter (nf_mpiio = 8192)
integer nf_mpiposix
parameter (nf_mpiposix = 16384)
integer nf_pnetcdf
parameter (nf_pnetcdf = 32768)
! For NF_VAR_PAR_ACCESS.
integer nf_independent
parameter (nf_independent = 0)
integer nf_collective
parameter (nf_collective = 1)
! New error codes.
integer nf_ehdferr ! Error at HDF5 layer.
parameter (nf_ehdferr = -101)
integer nf_ecantread ! Can't read.
parameter (nf_ecantread = -102)
integer nf_ecantwrite ! Can't write.
parameter (nf_ecantwrite = -103)
integer nf_ecantcreate ! Can't create.
parameter (nf_ecantcreate = -104)
integer nf_efilemeta ! Problem with file metadata.
parameter (nf_efilemeta = -105)
integer nf_edimmeta ! Problem with dimension metadata.
parameter (nf_edimmeta = -106)
integer nf_eattmeta ! Problem with attribute metadata.
parameter (nf_eattmeta = -107)
integer nf_evarmeta ! Problem with variable metadata.
parameter (nf_evarmeta = -108)
integer nf_enocompound ! Not a compound type.
parameter (nf_enocompound = -109)
integer nf_eattexists ! Attribute already exists.
parameter (nf_eattexists = -110)
integer nf_enotnc4 ! Attempting netcdf-4 operation on netcdf-3 file.
parameter (nf_enotnc4 = -111)
integer nf_estrictnc3 ! Attempting netcdf-4 operation on strict nc3 netcdf-4 file.
parameter (nf_estrictnc3 = -112)
integer nf_enotnc3 ! Attempting netcdf-3 operation on netcdf-4 file.
parameter (nf_enotnc3 = -113)
integer nf_enopar ! Parallel operation on file opened for non-parallel access.
parameter (nf_enopar = -114)
integer nf_eparinit ! Error initializing for parallel access.
parameter (nf_eparinit = -115)
integer nf_ebadgrpid ! Bad group ID.
parameter (nf_ebadgrpid = -116)
integer nf_ebadtypid ! Bad type ID.
parameter (nf_ebadtypid = -117)
integer nf_etypdefined ! Type has already been defined and may not be edited.
parameter (nf_etypdefined = -118)
integer nf_ebadfield ! Bad field ID.
parameter (nf_ebadfield = -119)
integer nf_ebadclass ! Bad class.
parameter (nf_ebadclass = -120)
integer nf_emaptype ! Mapped access for atomic types only.
parameter (nf_emaptype = -121)
integer nf_elatefill ! Attempt to define fill value when data already exists.
parameter (nf_elatefill = -122)
integer nf_elatedef ! Attempt to define var properties, like deflate, after enddef.
parameter (nf_elatedef = -123)
integer nf_edimscale ! Probem with HDF5 dimscales.
parameter (nf_edimscale = -124)
integer nf_enogrp ! No group found.
parameter (nf_enogrp = -125)
! New functions.
! Parallel I/O.
integer nf_create_par
external nf_create_par
integer nf_open_par
external nf_open_par
integer nf_var_par_access
external nf_var_par_access
! Functions to handle groups.
integer nf_inq_ncid
external nf_inq_ncid
integer nf_inq_grps
external nf_inq_grps
integer nf_inq_grpname
external nf_inq_grpname
integer nf_inq_grpname_full
external nf_inq_grpname_full
integer nf_inq_grpname_len
external nf_inq_grpname_len
integer nf_inq_grp_parent
external nf_inq_grp_parent
integer nf_inq_grp_ncid
external nf_inq_grp_ncid
integer nf_inq_grp_full_ncid
external nf_inq_grp_full_ncid
integer nf_inq_varids
external nf_inq_varids
integer nf_inq_dimids
external nf_inq_dimids
integer nf_def_grp
external nf_def_grp
! New rename grp function
integer nf_rename_grp
external nf_rename_grp
! New options for netCDF variables.
integer nf_def_var_deflate
external nf_def_var_deflate
integer nf_inq_var_deflate
external nf_inq_var_deflate
integer nf_def_var_szip
external nf_def_var_szip
integer nf_inq_var_szip
external nf_inq_var_szip
integer nf_def_var_fletcher32
external nf_def_var_fletcher32
integer nf_inq_var_fletcher32
external nf_inq_var_fletcher32
integer nf_def_var_chunking
external nf_def_var_chunking
integer nf_inq_var_chunking
external nf_inq_var_chunking
integer nf_def_var_fill
external nf_def_var_fill
integer nf_inq_var_fill
external nf_inq_var_fill
integer nf_def_var_endian
external nf_def_var_endian
integer nf_inq_var_endian
external nf_inq_var_endian
integer nf_def_var_filter
external nf_def_var_filter
integer nf_inq_var_filter
external nf_inq_var_filter
! User defined types.
integer nf_inq_typeids
external nf_inq_typeids
integer nf_inq_typeid
external nf_inq_typeid
integer nf_inq_type
external nf_inq_type
integer nf_inq_user_type
external nf_inq_user_type
! User defined types - compound types.
integer nf_def_compound
external nf_def_compound
integer nf_insert_compound
external nf_insert_compound
integer nf_insert_array_compound
external nf_insert_array_compound
integer nf_inq_compound
external nf_inq_compound
integer nf_inq_compound_name
external nf_inq_compound_name
integer nf_inq_compound_size
external nf_inq_compound_size
integer nf_inq_compound_nfields
external nf_inq_compound_nfields
integer nf_inq_compound_field
external nf_inq_compound_field
integer nf_inq_compound_fieldname
external nf_inq_compound_fieldname
integer nf_inq_compound_fieldindex
external nf_inq_compound_fieldindex
integer nf_inq_compound_fieldoffset
external nf_inq_compound_fieldoffset
integer nf_inq_compound_fieldtype
external nf_inq_compound_fieldtype
integer nf_inq_compound_fieldndims
external nf_inq_compound_fieldndims
integer nf_inq_compound_fielddim_sizes
external nf_inq_compound_fielddim_sizes
! User defined types - variable length arrays.
integer nf_def_vlen
external nf_def_vlen
integer nf_inq_vlen
external nf_inq_vlen
integer nf_free_vlen
external nf_free_vlen
! User defined types - enums.
integer nf_def_enum
external nf_def_enum
integer nf_insert_enum
external nf_insert_enum
integer nf_inq_enum
external nf_inq_enum
integer nf_inq_enum_member
external nf_inq_enum_member
integer nf_inq_enum_ident
external nf_inq_enum_ident
! User defined types - opaque.
integer nf_def_opaque
external nf_def_opaque
integer nf_inq_opaque
external nf_inq_opaque
! Write and read attributes of any type, including user defined
! types.
integer nf_put_att
external nf_put_att
integer nf_get_att
external nf_get_att
! Write and read variables of any type, including user defined
! types.
integer nf_put_var
external nf_put_var
integer nf_put_var1
external nf_put_var1
integer nf_put_vara
external nf_put_vara
integer nf_put_vars
external nf_put_vars
integer nf_get_var
external nf_get_var
integer nf_get_var1
external nf_get_var1
integer nf_get_vara
external nf_get_vara
integer nf_get_vars
external nf_get_vars
! For helping F77 users with VLENs.
integer nf_get_vlen_element
external nf_get_vlen_element
integer nf_put_vlen_element
external nf_put_vlen_element
! For dealing with file level chunk cache.
integer nf_set_chunk_cache
external nf_set_chunk_cache
integer nf_get_chunk_cache
external nf_get_chunk_cache
! For dealing with per variable chunk cache.
integer nf_set_var_chunk_cache
external nf_set_var_chunk_cache
integer nf_get_var_chunk_cache
external nf_get_var_chunk_cache
! NetCDF-2.
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
! begin netcdf 2.4 backward compatibility:
!
!
! functions in the fortran interface
!
integer nccre
integer ncopn
integer ncddef
integer ncdid
integer ncvdef
integer ncvid
integer nctlen
integer ncsfil
external nccre
external ncopn
external ncddef
external ncdid
external ncvdef
external ncvid
external nctlen
external ncsfil
integer ncrdwr
integer nccreat
integer ncexcl
integer ncindef
integer ncnsync
integer nchsync
integer ncndirty
integer nchdirty
integer nclink
integer ncnowrit
integer ncwrite
integer ncclob
integer ncnoclob
integer ncglobal
integer ncfill
integer ncnofill
integer maxncop
integer maxncdim
integer maxncatt
integer maxncvar
integer maxncnam
integer maxvdims
integer ncnoerr
integer ncebadid
integer ncenfile
integer nceexist
integer nceinval
integer nceperm
integer ncenotin
integer nceindef
integer ncecoord
integer ncemaxds
integer ncename
integer ncenoatt
integer ncemaxat
integer ncebadty
integer ncebadd
integer ncests
integer nceunlim
integer ncemaxvs
integer ncenotvr
integer nceglob
integer ncenotnc
integer ncfoobar
integer ncsyserr
integer ncfatal
integer ncverbos
integer ncentool
!
! netcdf data types:
!
integer ncbyte
integer ncchar
integer ncshort
integer nclong
integer ncfloat
integer ncdouble
parameter(ncbyte = 1)
parameter(ncchar = 2)
parameter(ncshort = 3)
parameter(nclong = 4)
parameter(ncfloat = 5)
parameter(ncdouble = 6)
!
! masks for the struct nc flag field; passed in as 'mode' arg to
! nccreate and ncopen.
!
! read/write, 0 => readonly
parameter(ncrdwr = 1)
! in create phase, cleared by ncendef
parameter(nccreat = 2)
! on create destroy existing file
parameter(ncexcl = 4)
! in define mode, cleared by ncendef
parameter(ncindef = 8)
! synchronise numrecs on change (x'10')
parameter(ncnsync = 16)
! synchronise whole header on change (x'20')
parameter(nchsync = 32)
! numrecs has changed (x'40')
parameter(ncndirty = 64)
! header info has changed (x'80')
parameter(nchdirty = 128)
! prefill vars on endef and increase of record, the default behavior
parameter(ncfill = 0)
! do not fill vars on endef and increase of record (x'100')
parameter(ncnofill = 256)
! isa link (x'8000')
parameter(nclink = 32768)
!
! 'mode' arguments for nccreate and ncopen
!
parameter(ncnowrit = 0)
parameter(ncwrite = ncrdwr)
parameter(ncclob = nf_clobber)
parameter(ncnoclob = nf_noclobber)
!
! 'size' argument to ncdimdef for an unlimited dimension
!
integer ncunlim
parameter(ncunlim = 0)
!
! attribute id to put/get a global attribute
!
parameter(ncglobal = 0)
!
! advisory maximums:
!
parameter(maxncop = 64)
parameter(maxncdim = 1024)
parameter(maxncatt = 8192)
parameter(maxncvar = 8192)
! not enforced
parameter(maxncnam = 256)
parameter(maxvdims = maxncdim)
!
! global netcdf error status variable
! initialized in error.c
!
! no error
parameter(ncnoerr = nf_noerr)
! not a netcdf id
parameter(ncebadid = nf_ebadid)
! too many netcdfs open
parameter(ncenfile = -31) ! nc_syserr
! netcdf file exists && ncnoclob
parameter(nceexist = nf_eexist)
! invalid argument
parameter(nceinval = nf_einval)
! write to read only
parameter(nceperm = nf_eperm)
! operation not allowed in data mode
parameter(ncenotin = nf_enotindefine )
! operation not allowed in define mode
parameter(nceindef = nf_eindefine)
! coordinates out of domain
parameter(ncecoord = nf_einvalcoords)
! maxncdims exceeded
parameter(ncemaxds = nf_emaxdims)
! string match to name in use
parameter(ncename = nf_enameinuse)
! attribute not found
parameter(ncenoatt = nf_enotatt)
! maxncattrs exceeded
parameter(ncemaxat = nf_emaxatts)
! not a netcdf data type
parameter(ncebadty = nf_ebadtype)
! invalid dimension id
parameter(ncebadd = nf_ebaddim)
! ncunlimited in the wrong index
parameter(nceunlim = nf_eunlimpos)
! maxncvars exceeded
parameter(ncemaxvs = nf_emaxvars)
! variable not found
parameter(ncenotvr = nf_enotvar)
! action prohibited on ncglobal varid
parameter(nceglob = nf_eglobal)
! not a netcdf file
parameter(ncenotnc = nf_enotnc)
parameter(ncests = nf_ests)
parameter (ncentool = nf_emaxname)
parameter(ncfoobar = 32)
parameter(ncsyserr = -31)
!
! global options variable. used to determine behavior of error handler.
! initialized in lerror.c
!
parameter(ncfatal = 1)
parameter(ncverbos = 2)
!
! default fill values. these must be the same as in the c interface.
!
integer filbyte
integer filchar
integer filshort
integer fillong
real filfloat
doubleprecision fildoub
parameter (filbyte = -127)
parameter (filchar = 0)
parameter (filshort = -32767)
parameter (fillong = -2147483647)
parameter (filfloat = 9.9692099683868690e+36)
parameter (fildoub = 9.9692099683868690e+36)
! This is to turn on netCDF internal logging.
integer nf_set_log_level
external nf_set_log_level
# 56 "../axis_utils/axis_utils.F90" 2
public get_axis_cart, get_axis_bounds, get_axis_modulo, get_axis_fold, lon_in_range, &
tranlon, frac_index, nearest_index, interp_1d, get_axis_modulo_times
private
integer, parameter :: maxatts = 100
real, parameter :: epsln= 1.e-10
real, parameter :: fp5 = 0.5, f360 = 360.0
! Include variable "version" to be written to log file.
# 1 "../include/file_version.h" 1
! -*-f90-*-
!***********************************************************************
!* GNU Lesser General Public License
!*
!* This file is part of the GFDL Flexible Modeling System (FMS).
!*
!* FMS is free software: you can redistribute it and/or modify it under
!* the terms of the GNU Lesser General Public License as published by
!* the Free Software Foundation, either version 3 of the License, or (at
!* your option) any later version.
!*
!* FMS is distributed in the hope that it will be useful, but WITHOUT
!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
!* for more details.
!*
!* You should have received a copy of the GNU Lesser General Public
!* License along with FMS. If not, see .
!***********************************************************************
# 23
character(len=*), parameter :: version = 'unknown'
# 68 "../axis_utils/axis_utils.F90" 2
interface interp_1d
module procedure interp_1d_1d
module procedure interp_1d_2d
module procedure interp_1d_3d
end interface
contains
subroutine get_axis_cart(axis, cart)
type(axistype), intent(in) :: axis
character(len=1), intent(out) :: cart
character(len=1) :: axis_cart
character(len=16), dimension(2) :: lon_names, lat_names
character(len=16), dimension(3) :: z_names
character(len=16), dimension(2) :: t_names
character(len=16), dimension(3) :: lon_units, lat_units
character(len=8) , dimension(4) :: z_units
character(len=3) , dimension(6) :: t_units
character(len=32) :: name
integer :: i,j
lon_names = (/'lon','x '/)
lat_names = (/'lat','y '/)
z_names = (/'depth ','height','z '/)
t_names = (/'time','t '/)
lon_units = (/'degrees_e ', 'degrees_east', 'degreese '/)
lat_units = (/'degrees_n ', 'degrees_north', 'degreesn '/)
z_units = (/'cm ','m ','pa ','hpa'/)
t_units = (/'sec', 'min','hou','day','mon','yea'/)
call mpp_get_atts(axis,cartesian=axis_cart)
cart = 'N'
if ( lowercase(axis_cart) == 'x' ) cart = 'X'
if ( lowercase(axis_cart) == 'y' ) cart = 'Y'
if ( lowercase(axis_cart) == 'z' ) cart = 'Z'
if ( lowercase(axis_cart) == 't' ) cart = 'T'
if (cart /= 'X' .and. cart /= 'Y' .and. cart /= 'Z' .and. cart /= 'T') then
call mpp_get_atts(axis,name=name)
name = lowercase(name)
do i=1,size(lon_names(:))
if (trim(name(1:3)) == trim(lon_names(i))) cart = 'X'
enddo
do i=1,size(lat_names(:))
if (trim(name(1:3)) == trim(lat_names(i))) cart = 'Y'
enddo
do i=1,size(z_names(:))
if (trim(name) == trim(z_names(i))) cart = 'Z'
enddo
do i=1,size(t_names(:))
if (trim(name) == t_names(i)) cart = 'T'
enddo
end if
if (cart /= 'X' .and. cart /= 'Y' .and. cart /= 'Z' .and. cart /= 'T') then
call mpp_get_atts(axis,units=name)
name = lowercase(name)
do i=1,size(lon_units(:))
if (trim(name) == trim(lon_units(i))) cart = 'X'
enddo
do i=1,size(lat_units(:))
if (trim(name) == trim(lat_units(i))) cart = 'Y'
enddo
do i=1,size(z_units(:))
if (trim(name) == trim(z_units(i))) cart = 'Z'
enddo
do i=1,size(t_units(:))
if (name(1:3) == trim(t_units(i))) cart = 'T'
enddo
end if
return
end subroutine get_axis_cart
subroutine get_axis_bounds(axis,axis_bound,axes,bnd_name,err_msg)
type(axistype), intent(in) :: axis
type(axistype), intent(inout) :: axis_bound
type(axistype), intent(in), dimension(:) :: axes
character(len=*), intent(inout), optional :: bnd_name
character(len=*), intent(out), optional :: err_msg
real, dimension(:), allocatable :: data, tmp
integer :: i, len
character(len=128) :: name, units
character(len=256) :: longname
character(len=1) :: cartesian
logical :: bounds_found
if(present(err_msg)) then
err_msg = ''
endif
axis_bound = default_axis
call mpp_get_atts(axis,units=units,longname=longname,&
cartesian=cartesian, len=len)
if(len .LE. 0) return
allocate(data(len+1))
bounds_found = mpp_get_axis_bounds(axis, data, name=name)
longname = trim(longname)//' bounds'
if(.not.bounds_found .and. len>1 ) then
! The following calculation can not be done for len=1
call mpp_get_atts(axis,name=name)
name = trim(name)//'_bnds'
allocate(tmp(len))
call mpp_get_axis_data(axis,tmp)
do i=2,len
data(i)= tmp(i-1)+fp5*(tmp(i)-tmp(i-1))
enddo
data(1)= tmp(1)- fp5*(tmp(2)-tmp(1))
if (abs(data(1)) < epsln) data(1) = 0.0
data(len+1)= tmp(len)+ fp5*(tmp(len)-tmp(len-1))
if (data(1) == 0.0) then
if (abs(data(len+1)-360.) > epsln) data(len+1)=360.0
endif
endif
if(bounds_found .OR. len>1) then
call mpp_modify_meta(axis_bound,name=name,units=units,longname=&
longname,cartesian=cartesian,data=data)
endif
if(allocated(tmp)) deallocate(tmp)
deallocate(data)
return
end subroutine get_axis_bounds
function get_axis_modulo(axis)
type(axistype) :: axis
logical :: get_axis_modulo
integer :: natt, i
type(atttype), dimension(:), allocatable :: atts
call mpp_get_atts(axis,natts=natt)
allocate(atts(natt))
call mpp_get_atts(axis,atts=atts)
get_axis_modulo=.false.
do i = 1,natt
if (lowercase(trim(mpp_get_att_name(atts(i)))) == 'modulo') get_axis_modulo = .true.
enddo
deallocate(atts)
return
end function get_axis_modulo
function get_axis_modulo_times(axis, tbeg, tend)
logical :: get_axis_modulo_times
type(axistype), intent(in) :: axis
character(len=*), intent(out) :: tbeg, tend
integer :: natt, i
type(atttype), dimension(:), allocatable :: atts
logical :: found_tbeg, found_tend
call mpp_get_atts(axis,natts=natt)
allocate(atts(natt))
call mpp_get_atts(axis,atts=atts)
found_tbeg = .false.
found_tend = .false.
do i = 1,natt
if(lowercase(trim(mpp_get_att_name(atts(i)))) == 'modulo_beg') then
if(mpp_get_att_length(atts(i)) > len(tbeg)) then
call mpp_error(FATAL,'error in get: len(tbeg) too small to hold attribute')
endif
tbeg = trim(mpp_get_att_char(atts(i)))
found_tbeg = .true.
endif
if(lowercase(trim(mpp_get_att_name(atts(i)))) == 'modulo_end') then
if(mpp_get_att_length(atts(i)) > len(tend)) then
call mpp_error(FATAL,'error in get: len(tend) too small to hold attribute')
endif
tend = trim(mpp_get_att_char(atts(i)))
found_tend = .true.
endif
enddo
if(found_tbeg .and. .not.found_tend) then
call mpp_error(FATAL,'error in get: Found modulo_beg but not modulo_end')
endif
if(.not.found_tbeg .and. found_tend) then
call mpp_error(FATAL,'error in get: Found modulo_end but not modulo_beg')
endif
get_axis_modulo_times = found_tbeg
end function get_axis_modulo_times
function get_axis_fold(axis)
type(axistype) :: axis
logical :: get_axis_fold
integer :: natt, i
type(atttype), dimension(:), allocatable :: atts
call mpp_get_atts(axis,natts=natt)
allocate(atts(natt))
call mpp_get_atts(axis,atts=atts)
get_axis_fold=.false.
do i = 1,natt
if (mpp_get_att_char(atts(i)) == 'fold_top') get_axis_fold = .true.
enddo
deallocate(atts)
return
end function get_axis_fold
function lon_in_range(lon, l_strt)
real :: lon, l_strt, lon_in_range, l_end
lon_in_range = lon
l_end = l_strt+360.
if (abs(lon_in_range - l_strt) < 1.e-4) then
lon_in_range = l_strt
return
endif
if (abs(lon_in_range - l_end) < 1.e-4) then
lon_in_range = l_strt
return
endif
do
if (lon_in_range < l_strt) then
lon_in_range = lon_in_range + f360;
else if (lon_in_range > l_end) then
lon_in_range = lon_in_range - f360;
else
exit
end if
end do
end function lon_in_range
subroutine tranlon(lon, lon_start, istrt)
! returns array of longitudes s.t. lon_strt <= lon < lon_strt+360.
! also, the first istrt-1 entries are moved to the end of the array
!
! e.g.
! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==>
! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4
real, intent(inout), dimension(:) :: lon
real, intent(in) :: lon_start
integer, intent(out) :: istrt
integer :: len, i
real :: lon_strt, tmp(size(lon(:))-1)
len = size(lon(:))
do i=1,len
lon(i) = lon_in_range(lon(i),lon_start)
enddo
istrt=0
do i=1,len-1
if (lon(i+1) < lon(i)) then
istrt=i+1
exit
endif
enddo
if (istrt>1) then ! grid is not monotonic
if (abs(lon(len)-lon(1)) < epsln) then
tmp = cshift(lon(1:len-1),istrt-1)
lon(1:len-1) = tmp
lon(len) = lon(1)
else
lon = cshift(lon,istrt-1)
endif
lon_strt = lon(1)
do i=2,len+1
lon(i) = lon_in_range(lon(i),lon_strt)
lon_strt = lon(i)
enddo
endif
return
end subroutine tranlon
function frac_index (value, array)
!=======================================================================
!
! nearest_index = index of nearest data point within "array" corresponding to
! "value".
!
! inputs:
!
! value = arbitrary data...same units as elements in "array"
! array = array of data points (must be monotonically increasing)
!
! output:
!
! nearest_index = index of nearest data point to "value"
! if "value" is outside the domain of "array" then nearest_index = 1
! or "ia" depending on whether array(1) or array(ia) is
! closest to "value"
!
! note: if "array" is dimensioned array(0:ia) in the calling
! program, then the returned index should be reduced
! by one to account for the zero base.
!
! example:
!
! let model depths be defined by the following:
! parameter (km=5)
! dimension z(km)
! data z /5.0, 10.0, 50.0, 100.0, 250.0/
!
! k1 = nearest_index (12.5, z, km)
! k2 = nearest_index (0.0, z, km)
!
! k1 would be set to 2, and k2 would be set to 1 so that
! z(k1) would be the nearest data point to 12.5 and z(k2) would
! be the nearest data point to 0.0
!
!=======================================================================
integer :: ia, i, ii, unit
real :: value, frac_index
real, dimension(:) :: array
logical keep_going
ia = size(array(:))
do i=2,ia
if (array(i) < array(i-1)) then
unit = stdout()
write (unit,*) '=> Error: "frac_index" array must be monotonically increasing when searching for nearest value to ',&
value
write (unit,*) ' array(i) < array(i-1) for i=',i
write (unit,*) ' array(i) for i=1..ia follows:'
do ii=1,ia
write (unit,*) 'i=',ii, ' array(i)=',array(ii)
enddo
call mpp_error(FATAL,' "frac_index" array must be monotonically increasing.')
endif
enddo
if (value < array(1) .or. value > array(ia)) then
! if (value < array(1)) frac_index = 1.
! if (value > array(ia)) frac_index = float(ia)
frac_index = -1.0
else
i=1
keep_going = .true.
do while (i <= ia .and. keep_going)
i = i+1
if (value <= array(i)) then
frac_index = float(i-1) + (value-array(i-1))/(array(i)-array(i-1))
keep_going = .false.
endif
enddo
endif
end function frac_index
function nearest_index (value, array)
!=======================================================================
!
! nearest_index = index of nearest data point within "array" corresponding to
! "value".
!
! inputs:
!
! value = arbitrary data...same units as elements in "array"
! array = array of data points (must be monotonically increasing)
! ia = dimension of "array"
!
! output:
!
! nearest_index = index of nearest data point to "value"
! if "value" is outside the domain of "array" then nearest_index = 1
! or "ia" depending on whether array(1) or array(ia) is
! closest to "value"
!
! note: if "array" is dimensioned array(0:ia) in the calling
! program, then the returned index should be reduced
! by one to account for the zero base.
!
! example:
!
! let model depths be defined by the following:
! parameter (km=5)
! dimension z(km)
! data z /5.0, 10.0, 50.0, 100.0, 250.0/
!
! k1 = nearest_index (12.5, z, km)
! k2 = nearest_index (0.0, z, km)
!
! k1 would be set to 2, and k2 would be set to 1 so that
! z(k1) would be the nearest data point to 12.5 and z(k2) would
! be the nearest data point to 0.0
!
!=======================================================================
integer :: nearest_index, ia, i, ii, unit
real :: value
real, dimension(:) :: array
logical keep_going
ia = size(array(:))
do i=2,ia
if (array(i) < array(i-1)) then
unit = stdout()
write (unit,*) '=> Error: "nearest_index" array must be monotonically increasing &
&when searching for nearest value to ',value
write (unit,*) ' array(i) < array(i-1) for i=',i
write (unit,*) ' array(i) for i=1..ia follows:'
do ii=1,ia
write (unit,*) 'i=',ii, ' array(i)=',array(ii)
enddo
call mpp_error(FATAL,' "nearest_index" array must be monotonically increasing.')
endif
enddo
if (value < array(1) .or. value > array(ia)) then
if (value < array(1)) nearest_index = 1
if (value > array(ia)) nearest_index = ia
else
i=1
keep_going = .true.
do while (i <= ia .and. keep_going)
i = i+1
if (value <= array(i)) then
nearest_index = i
if (array(i)-value > value-array(i-1)) nearest_index = i-1
keep_going = .false.
endif
enddo
endif
end function nearest_index
!#############################################################################
subroutine interp_1d_linear(grid1,grid2,data1,data2)
real, dimension(:), intent(in) :: grid1, data1, grid2
real, dimension(:), intent(inout) :: data2
integer :: n1, n2, i, n, ext
real :: w
n1 = size(grid1(:))
n2 = size(grid2(:))
do i=2,n1
if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic')
enddo
do i=2,n2
if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic')
enddo
if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1')
if (grid1(n1) < grid2(n2) ) call mpp_error(FATAL, 'grid2 lies outside grid1')
do i=1,n2
n = nearest_index(grid2(i),grid1)
if (grid1(n) < grid2(i)) then
w = (grid2(i)-grid1(n))/(grid1(n+1)-grid1(n))
data2(i) = (1.-w)*data1(n) + w*data1(n+1)
else
if(n==1) then
data2(i) = data1(n)
else
w = (grid2(i)-grid1(n-1))/(grid1(n)-grid1(n-1))
data2(i) = (1.-w)*data1(n-1) + w*data1(n)
endif
endif
enddo
return
end subroutine interp_1d_linear
!###################################################################
subroutine interp_1d_cubic_spline(grid1, grid2, data1, data2, yp1, ypn)
real, dimension(:), intent(in) :: grid1, grid2, data1
real, dimension(:), intent(inout) :: data2
real, intent(in) :: yp1, ypn
real, dimension(size(grid1)) :: y2, u
real :: sig, p, qn, un, h, a ,b
integer :: n, m, i, k, klo, khi
n = size(grid1(:))
m = size(grid2(:))
do i=2,n
if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic')
enddo
do i=2,m
if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic')
enddo
if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1')
if (grid1(n) < grid2(m) ) call mpp_error(FATAL, 'grid2 lies outside grid1')
if (yp1 >.99e30) then
y2(1)=0.
u(1)=0.
else
y2(1)=-0.5
u(1)=(3./(grid1(2)-grid1(1)))*((data1(2)-data1(1))/(grid1(2)-grid1(1))-yp1)
endif
do i=2,n-1
sig=(grid1(i)-grid1(i-1))/(grid1(i+1)-grid1(i-1))
p=sig*y2(i-1)+2.
y2(i)=(sig-1.)/p
u(i)=(6.*((data1(i+1)-data1(i))/(grid1(i+1)-grid1(i))-(data1(i)-data1(i-1)) &
/(grid1(i)-grid1(i-1)))/(grid1(i+1)-grid1(i-1))-sig*u(i-1))/p
enddo
if (ypn > .99e30) then
qn=0.
un=0.
else
qn=0.5
un=(3./(grid1(n)-grid1(n-1)))*(ypn-(data1(n)-data1(n-1))/(grid1(n)-grid1(n-1)))
endif
y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
do k=n-1,1,-1
y2(k)=y2(k)*y2(k+1)+u(k)
enddo
do k = 1, m
n = nearest_index(grid2(k),grid1)
if (grid1(n) < grid2(k)) then
klo = n
else
if(n==1) then
klo = n
else
klo = n -1
endif
endif
khi = klo+1
h = grid1(khi)-grid1(klo)
a = (grid1(khi) - grid2(k))/h
b = (grid2(k) - grid1(klo))/h
data2(k) = a*data1(klo) + b*data1(khi)+ ((a**3-a)*y2(klo) + (b**3-b)*y2(khi))*(h**2)/6.
enddo
end subroutine interp_1d_cubic_spline
!###################################################################
subroutine interp_1d_1d(grid1,grid2,data1,data2, method, yp1, yp2)
real, dimension(:), intent(in) :: grid1, data1, grid2
real, dimension(:), intent(inout) :: data2
character(len=*), optional, intent(in) :: method
real, optional, intent(in) :: yp1, yp2
real :: y1, y2
character(len=32) :: interp_method
integer :: k2, ks, ke
k2 = size(grid2(:))
interp_method = "linear"
if(present(method)) interp_method = method
y1 = 1.0e30
if(present(yp1)) y1 = yp1
y2 = 1.0e30
if(present(yp2)) y2 = yp2
call find_index(grid1, grid2(1), grid2(k2), ks, ke)
select case(trim(interp_method))
case("linear")
call interp_1d_linear(grid1(ks:ke),grid2,data1(ks:ke),data2)
case("cubic_spline")
call interp_1d_cubic_spline(grid1(ks:ke),grid2,data1(ks:ke),data2, y1, y2)
case default
call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline")
end select
return
end subroutine interp_1d_1d
!###################################################################
subroutine interp_1d_2d(grid1,grid2,data1,data2)
real, dimension(:,:), intent(in) :: grid1, data1, grid2
real, dimension(:,:), intent(inout) :: data2
integer :: n1, n2, i, n, k2, ks, ke
real :: w
n1 = size(grid1,1)
n2 = size(grid2,1)
k2 = size(grid2,2)
if (n1 /= n2) call mpp_error(FATAL,'grid size mismatch')
do n=1,n1
call find_index(grid1(n,:), grid2(n,1), grid2(n,k2), ks, ke)
call interp_1d_linear(grid1(n,ks:ke),grid2(n,:),data1(n,ks:ke),data2(n,:))
enddo
return
end subroutine interp_1d_2d
!###################################################################
subroutine interp_1d_3d(grid1,grid2,data1,data2, method, yp1, yp2)
real, dimension(:,:,:), intent(in) :: grid1, data1, grid2
real, dimension(:,:,:), intent(inout) :: data2
character(len=*), optional, intent(in) :: method
real, optional, intent(in) :: yp1, yp2
integer :: n1, n2, m1, m2, k2, i, n, m
real :: w, y1, y2
character(len=32) :: interp_method
integer :: ks, ke
n1 = size(grid1,1)
n2 = size(grid2,1)
m1 = size(grid1,2)
m2 = size(grid2,2)
k2 = size(grid2,3)
interp_method = "linear"
if(present(method)) interp_method = method
y1 = 1.0e30
if(present(yp1)) y1 = yp1
y2 = 1.0e30
if(present(yp2)) y2 = yp2
if (n1 /= n2 .or. m1 /= m2) call mpp_error(FATAL,'grid size mismatch')
select case(trim(interp_method))
case("linear")
do m=1,m1
do n=1,n1
call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke)
call interp_1d_linear(grid1(n,m,ks:ke),grid2(n,m,:),data1(n,m,ks:ke),data2(n,m,:))
enddo
enddo
case("cubic_spline")
do m=1,m1
do n=1,n1
call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke)
call interp_1d_cubic_spline(grid1(n,m,ks:ke),grid2(n,m,:), data1(n,m,ks:ke),data2(n,m,:), y1, y2)
enddo
enddo
case default
call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline")
end select
return
end subroutine interp_1d_3d
!#####################################################################
subroutine find_index(grid1, xs, xe, ks, ke)
real, dimension(:), intent(in) :: grid1
real, intent(in) :: xs, xe
integer, intent(out) :: ks, ke
integer :: k, nk
nk = size(grid1(:))
ks = 0; ke = 0
do k = 1, nk-1
if(grid1(k) <= xs .and. grid1(k+1) > xs ) then
ks = k
exit
endif
enddo
do k = nk, 2, -1
if(grid1(k) >= xe .and. grid1(k-1) < xe ) then
ke = k
exit
endif
enddo
if(ks == 0 ) call mpp_error(FATAL,' xs locate outside of grid1')
if(ke == 0 ) call mpp_error(FATAL,' xe locate outside of grid1')
end subroutine find_index
end module axis_utils_mod