Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
8668 lines (7529 sloc) 378 KB
!***********************************************************************
!* 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 <http://www.gnu.org/licenses/>.
!***********************************************************************
module fms_io_mod
#include <fms_platform.h>
!
!
! <CONTACT EMAIL="Zhi.Liang@noaa.gov">
! Zhi Liang
! </CONTACT>
! <CONTACT EMAIL="Matthew.Harrison@noaa.gov">
! M.J. Harrison
! </CONTACT>
!
! <REVIEWER EMAIL="Matthew.Harrison@noaa.gov">
! M.J. Harrison
! </REVIEWER>
! <REVIEWER EMAIL="Bruce.Wyman@noaa.gov">
! B. Wyman
! </REVIEWER>
!<DESCRIPTION>
! This module is for writing and reading restart data in NetCDF format.
! fms_io_init must be called before the first write_data/read_data call
! For writing, fms_io_exit must be called after ALL write calls have
! been made. Typically, fms_io_init and fms_io_exit are placed in the
! main (driver) program while read_data and write_data can be called where needed.
! Presently, two combinations of threading and fileset are supported, users can choose
! one line of the following by setting namelist:
!
! With the introduction of netCDF restart files, there is a need for a global
! switch to turn on/off netCDF restart options in all of the modules that deal with
! restart files. Here two more namelist variables (logical type) are introduced to fms_io
!
! fms_netcdf_override
! fms_netcdf_restart
!
! because default values of both flags are .true., the default behavior of the entire model is
! to use netCDF IO mode. To turn off netCDF restart, simply set fms_netcdf_restart to .false.
!
!</DESCRIPTION>
! <NAMELIST NAME="fms_io_nml">
! <DATA NAME="threading_read" TYPE="character">
! threading_read can be 'single' or 'multi'
! </DATA>
! <DATA NAME="fms_netcdf_override" TYPE="logical">
! .true. : fms_netcdf_restart overrides individual do_netcdf_restart value (default behavior)
! .false.: individual module settings has a precedence over the global setting, therefore fms_netcdf_restart is ignored
! </DATA>
! <DATA NAME="fms_netcdf_restart" TYPE="logical">
! .true. : all modules deal with restart files will operate under netCDF mode (default behavior)
! .false.: all modules deal with restart files will operate under binary mode
! This flag is effective only when fms_netcdf_override is .true. When fms_netcdf_override is .false., individual
! module setting takes over.
! </DATA>
! <DATA NAME="time_stamped_restart" TYPE="logical">
! .true. : time_stamp will be added to the restart file name as a prefix when
! optional argument time_stamp is passed into routine save_restart.
! .false.: time_stmp will not be added to the restart file name even though
! time_stamp is passed into save_restart.
! default is true.
! </DATA>
! <DATA NAME="print_chksum" TYPE="logical">
! set print_chksum (default is false) to true to print out chksum of fields that are
! read and written through save_restart/restore_state. The chksum is accross all the
! processors, so there will be only one chksum even there are multiple-tiles in the
! grid. For the multiple case, the filename appeared in the message will contain
! tile1 because the message is print out from root pe and on root pe the tile id is tile1.
! </DATA>
! <DATA NAME="debug_mask_list" TYPE="logical">
! set debug_mask_list (default is false) to true to print out mask_list reading from mask_table.
! </DATA>
! <DATA NAME="checksum_required" TYPE="logical">
! Set checksum_required (default is true) to true to compare checksums stored in the attribute of a
! field against the checksum after reading in the data. This check mitigates the possibility of data
! that gets corrupted on write or read from being used in a n ongoing fashion. The checksum is across
! all the processors, so there will be only one checksum even if there are multiple-tiles in the
! grid. For the decomposed file case, the filename appearing in the message will contain tile1
! because the message is printed out from the root pe and on root pe the tile id is tile1.
!
! Set checksum_required to false if you do not want to compare checksums.
! </DATA>
!</NAMELIST>
use mpp_io_mod, only: mpp_open, mpp_close, mpp_io_init, mpp_io_exit, mpp_read, mpp_write
use mpp_io_mod, only: mpp_write_meta, mpp_get_info, mpp_get_atts, mpp_get_fields
use mpp_io_mod, only: mpp_read_compressed, mpp_write_compressed, mpp_def_dim
use mpp_io_mod, only: mpp_write_unlimited_axis, mpp_read_distributed_ascii
use mpp_io_mod, only: mpp_get_axes, mpp_get_axis_data, mpp_get_att_char, mpp_get_att_name
use mpp_io_mod, only: mpp_get_att_real_scalar, mpp_attribute_exist, mpp_is_dist_ioroot
use mpp_io_mod, only: fieldtype, axistype, atttype, default_field, default_axis, default_att
use mpp_io_mod, only: MPP_NETCDF, MPP_ASCII, MPP_MULTI, MPP_SINGLE, MPP_OVERWR, MPP_RDONLY
use mpp_io_mod, only: MPP_IEEE32, MPP_NATIVE, MPP_DELETE, MPP_APPEND, MPP_SEQUENTIAL, MPP_DIRECT
use mpp_io_mod, only: MAX_FILE_SIZE, mpp_get_att_value
use mpp_io_mod, only: mpp_get_dimension_length
use mpp_domains_mod, only: domain2d, domain1d, NULL_DOMAIN1D, NULL_DOMAIN2D, operator( .EQ. )
use mpp_domains_mod, only: CENTER, EAST, WEST, NORTH, SOUTH, CORNER
use mpp_domains_mod, only: mpp_get_domain_components, mpp_get_compute_domain, mpp_get_data_domain
use mpp_domains_mod, only: mpp_get_domain_shift, mpp_get_global_domain, mpp_global_field, mpp_domain_is_tile_root_pe
use mpp_domains_mod, only: mpp_get_ntile_count, mpp_get_current_ntile, mpp_get_tile_id
use mpp_domains_mod, only: mpp_get_pelist, mpp_get_io_domain, mpp_get_domain_npes
use mpp_domains_mod, only: domainUG, mpp_pass_SG_to_UG, mpp_get_UG_domain_ntiles, mpp_get_UG_domain_tile_id
use mpp_mod, only: mpp_error, FATAL, NOTE, WARNING, mpp_pe, mpp_root_pe, mpp_npes, stdlog, stdout
use mpp_mod, only: mpp_broadcast, ALL_PES, mpp_chksum, mpp_get_current_pelist, mpp_npes, lowercase
use mpp_mod, only: input_nml_file, mpp_get_current_pelist_name, uppercase
use mpp_mod, only: mpp_gather, mpp_scatter, mpp_send, mpp_recv, mpp_sync_self, COMM_TAG_1, EVENT_RECV
use mpp_mod, only: MPP_FILL_DOUBLE,MPP_FILL_INT
use platform_mod, only: r8_kind
!----------
!ug support
use mpp_parameter_mod, only: COMM_TAG_2
use mpp_domains_mod, only: mpp_get_UG_io_domain
use mpp_domains_mod, only: mpp_domain_UG_is_tile_root_pe
use mpp_domains_mod, only: mpp_get_UG_domain_npes
use mpp_domains_mod, only: mpp_get_UG_domain_pelist
use mpp_io_mod, only: mpp_io_unstructured_write
use mpp_io_mod, only: mpp_io_unstructured_read
use mpp_io_mod, only: mpp_file_is_opened
!----------
implicit none
private
integer, parameter, private :: max_split_file = 50
integer, parameter, private :: max_fields=400
integer, parameter, private :: max_axes=40
integer, parameter, private :: max_atts=20
integer, parameter, private :: max_domains = 10
integer, parameter, private :: MAX_TIME_LEVEL_REGISTER = 2
integer, parameter, private :: MAX_TIME_LEVEL_WRITE = 20
integer, parameter :: max_axis_size=10000
! Index postions for axes in restart_file_type
! This is done so the user may define the axes
! in any order but a check can be performed
! to ensure no registration of duplicate axis
!----------
!ug support
integer(INT_KIND),parameter,public :: XIDX = 1
integer(INT_KIND),parameter,public :: YIDX = 2
integer(INT_KIND),parameter,public :: CIDX = 3
integer(INT_KIND),parameter,public :: ZIDX = 4
integer(INT_KIND),parameter,public :: HIDX = 5
integer(INT_KIND),parameter,public :: TIDX = 6
integer(INT_KIND),parameter,public :: UIDX = 7
integer(INT_KIND),parameter,public :: CCIDX = 8
!---------
integer, parameter, private :: NIDX=8
type meta_type
type(meta_type), pointer :: prev=>null(), next=>null()
!!$ Gfortran on gaea does not yet support deferred length character strings
!!$ character(len=:),allocatable :: name
character(len=256) :: name
real, allocatable :: rval(:)
integer, allocatable :: ival(:)
!!$ Gfortran on gaea does not yet support deferred length character strings
!!$ character(len=:), allocatable :: cval
character(len=256) :: cval
end type meta_type
type ax_type
private
character(len=128) :: name = ''
character(len=128) :: units = ''
character(len=128) :: longname = ''
character(len=8) :: cartesian = ''
character(len=256) :: compressed = ''
character(len=128) :: dimlen_name = ''
character(len=128) :: dimlen_lname = ''
character(len=128) :: calendar = ''
integer :: sense !Orientation of z axis definition
integer :: dimlen !max dim of elements across global domain
real :: min !valid min for real axis data
integer :: imin !valid min for integer axis data
integer,allocatable :: idx(:) !compressed io-domain index vector
integer,allocatable :: nelems(:) !num elements for each rank in io domain
real, pointer :: data(:) =>NULL() !real axis values (not used if time axis)
type(domain2d),pointer :: domain =>NULL() ! domain associated with compressed axis
!----------
!ug support
type(domainUG),pointer :: domain_ug => null() !<A pointer to an unstructured mpp domain.
integer(INT_KIND) :: nelems_for_current_rank !<The number of grid points registered to the current rank (used for error checking).
!----------
end type ax_type
type var_type
private
character(len=128) :: name = ''
character(len=128) :: longname = ''
character(len=128) :: units = ''
real, dimension(:,:,:,:), _ALLOCATABLE :: buffer _NULL
logical :: domain_present = .FALSE.
integer :: domain_idx = -1
logical :: is_dimvar = .FALSE.
logical :: read_only = .FALSE.
logical :: owns_data = .FALSE. ! if true, restart owns the data and will deallocate them when freed
type(fieldtype) :: field
type(axistype) :: axis
integer :: position
integer :: ndim
integer :: siz(5) ! X/Y/Z/T/A extent of fields (data domain
! size for distributed writes;global size for reads)
integer :: gsiz(4) ! global X/Y/Z/A extent of fields
integer :: id_axes(4) ! store index for x/y/z/a axistype.
logical :: initialized ! indicate if the field is read or not in routine save_state.
logical :: mandatory ! indicate if the field is mandatory to be when restart.
integer :: is, ie, js, je ! index of the data in compute domain
real :: default_data
character(len=8) :: compressed_axis !< If on a compressed axis, which axis
integer, dimension(:), allocatable :: pelist
integer :: ishift, jshift ! can be used to shift indices when no_domain=T
integer :: x_halo, y_halo ! can be used to indicate halo size when no_domain=T
!----------
!ug support
type(domainUG),pointer :: domain_ug => null() !<A pointer to an unstructured mpp domain.
integer(INT_KIND),dimension(5) :: field_dimension_order !<Array telling the ordering of the dimensions for the field.
integer(INT_KIND),dimension(NIDX) :: field_dimension_sizes !<Array of sizes of the dimensions for the field.
!----------
end type var_type
type Ptr0Dr
real, pointer :: p => NULL()
end type Ptr0Dr
type Ptr1Dr
real, dimension(:), pointer :: p => NULL()
end type Ptr1Dr
type Ptr2Dr
real, dimension(:,:), pointer :: p => NULL()
end type Ptr2Dr
type Ptr3Dr
real, dimension(:,:,:), pointer :: p => NULL()
end type Ptr3Dr
type Ptr2Dr8
real(DOUBLE_KIND), dimension(:,:), pointer :: p => NULL()
end type Ptr2Dr8
type Ptr3Dr8
real(DOUBLE_KIND), dimension(:,:,:), pointer :: p => NULL()
end type Ptr3Dr8
type Ptr4Dr
real, dimension(:,:,:,:), pointer :: p => NULL()
end type Ptr4Dr
type Ptr0Di
integer, pointer :: p => NULL()
end type Ptr0Di
type Ptr1Di
integer, dimension(:), pointer :: p => NULL()
end type Ptr1Di
type Ptr2Di
integer, dimension(:,:), pointer :: p => NULL()
end type Ptr2Di
type Ptr3Di
integer, dimension(:,:,:), pointer :: p => NULL()
end type Ptr3Di
type restart_file_type
private
integer :: unit = -1 ! mpp_io unit for netcdf file
character(len=128) :: name = ''
integer :: register_id = 0
integer :: nvar = 0
integer :: natt = 0
integer :: max_ntime = 0
logical :: is_root_pe = .FALSE.
logical :: is_compressed = .FALSE.
logical :: unlimited_axis = .FALSE.
integer :: tile_count = 1
type(ax_type), allocatable :: axes(:) ! Currently define X,Y,Compressed, unlimited and maybe Z
type(meta_type), pointer :: first =>NULL() ! pointer to first additional global metadata element
type(var_type), dimension(:), pointer :: var => NULL()
type(Ptr0Dr), dimension(:,:), pointer :: p0dr => NULL()
type(Ptr1Dr), dimension(:,:), pointer :: p1dr => NULL()
type(Ptr2Dr), dimension(:,:), pointer :: p2dr => NULL()
type(Ptr3Dr), dimension(:,:), pointer :: p3dr => NULL()
type(Ptr2Dr8), dimension(:,:), pointer :: p2dr8 => NULL()
type(Ptr3Dr8), dimension(:,:), pointer :: p3dr8 => NULL()
type(Ptr4Dr), dimension(:,:), pointer :: p4dr => NULL()
type(Ptr0Di), dimension(:,:), pointer :: p0di => NULL()
type(Ptr1Di), dimension(:,:), pointer :: p1di => NULL()
type(Ptr2Di), dimension(:,:), pointer :: p2di => NULL()
type(Ptr3Di), dimension(:,:), pointer :: p3di => NULL()
end type restart_file_type
interface read_data
module procedure read_data_4d_new
module procedure read_data_3d_new
module procedure read_data_2d_new
module procedure read_data_2d_UG
module procedure read_data_1d_new
module procedure read_data_scalar_new
module procedure read_data_i3d_new
module procedure read_data_i2d_new
module procedure read_data_i1d_new
module procedure read_data_iscalar_new
module procedure read_data_2d, read_ldata_2d, read_idata_2d
module procedure read_data_3d, read_data_4d
#ifdef OVERLOAD_C8
module procedure read_cdata_2d,read_cdata_3d,read_cdata_4d
#endif
module procedure read_data_text
module procedure read_data_2d_region
module procedure read_data_3d_region
#ifdef OVERLOAD_R8
module procedure read_data_2d_region_r8
module procedure read_data_3d_region_r8
#endif
end interface
interface read_distributed
module procedure read_distributed_r1D
module procedure read_distributed_r3D
module procedure read_distributed_r5D
module procedure read_distributed_i1D
module procedure read_distributed_iscalar
module procedure read_distributed_a1D
end interface
! Only need read compressed att; write is handled in with
! mpp_io calls in save_compressed_restart
interface read_compressed
module procedure read_compressed_i1d
module procedure read_compressed_i2d
module procedure read_compressed_1d
module procedure read_compressed_2d
module procedure read_compressed_3d
end interface read_compressed
interface write_data
module procedure write_data_4d_new
module procedure write_data_3d_new
module procedure write_data_2d_new
module procedure write_data_1d_new
module procedure write_data_scalar_new
module procedure write_data_i3d_new
module procedure write_data_i2d_new
module procedure write_data_i1d_new
module procedure write_data_iscalar_new
module procedure write_data_2d, write_ldata_2d, write_idata_2d
module procedure write_data_3d, write_data_4d
#ifdef OVERLOAD_C8
module procedure write_cdata_2d,write_cdata_3d,write_cdata_4d
#endif
end interface
interface register_restart_field
module procedure register_restart_field_r0d
module procedure register_restart_field_r1d
module procedure register_restart_field_r2d
module procedure register_restart_field_r3d
#ifdef OVERLOAD_R8
module procedure register_restart_field_r2d8
module procedure register_restart_field_r3d8
module procedure register_restart_field_r2d8_2level
module procedure register_restart_field_r3d8_2level
#endif
module procedure register_restart_field_r4d
module procedure register_restart_field_i0d
module procedure register_restart_field_i1d
module procedure register_restart_field_i2d
module procedure register_restart_field_i3d
module procedure register_restart_field_r0d_2level
module procedure register_restart_field_r1d_2level
module procedure register_restart_field_r2d_2level
module procedure register_restart_field_r3d_2level
module procedure register_restart_field_i0d_2level
module procedure register_restart_field_i1d_2level
module procedure register_restart_field_i2d_2level
module procedure register_restart_field_i3d_2level
module procedure register_restart_region_r2d
module procedure register_restart_region_r3d
end interface
interface register_restart_axis
module procedure register_restart_axis_r1d
module procedure register_restart_axis_i1d
module procedure register_restart_axis_unlimited
end interface
interface reset_field_pointer
module procedure reset_field_pointer_r0d
module procedure reset_field_pointer_r1d
module procedure reset_field_pointer_r2d
module procedure reset_field_pointer_r3d
module procedure reset_field_pointer_r4d
module procedure reset_field_pointer_i0d
module procedure reset_field_pointer_i1d
module procedure reset_field_pointer_i2d
module procedure reset_field_pointer_i3d
module procedure reset_field_pointer_r0d_2level
module procedure reset_field_pointer_r1d_2level
module procedure reset_field_pointer_r2d_2level
module procedure reset_field_pointer_r3d_2level
module procedure reset_field_pointer_i0d_2level
module procedure reset_field_pointer_i1d_2level
module procedure reset_field_pointer_i2d_2level
module procedure reset_field_pointer_i3d_2level
end interface
interface restore_state
module procedure restore_state_all
module procedure restore_state_one_field
end interface
interface query_initialized
module procedure query_initialized_id
module procedure query_initialized_name
module procedure query_initialized_r2d
module procedure query_initialized_r3d
module procedure query_initialized_r4d
end interface
interface set_initialized
module procedure set_initialized_id
module procedure set_initialized_name
module procedure set_initialized_r2d
module procedure set_initialized_r3d
module procedure set_initialized_r4d
end interface
interface get_global_att_value
module procedure get_global_att_value_text
module procedure get_global_att_value_real
end interface
interface get_var_att_value
module procedure get_var_att_value_text
end interface
interface parse_mask_table
module procedure parse_mask_table_2d
module procedure parse_mask_table_3d
end interface
interface get_mosaic_tile_file
module procedure get_mosaic_tile_file_sg
module procedure get_mosaic_tile_file_ug
end interface
integer :: num_files_r = 0 ! number of currently opened files for reading
integer :: num_files_w = 0 ! number of currently opened files for writing
integer :: num_domains = 0 ! number of domains in array_domain
integer :: num_registered_files = 0 ! mumber of files registered by calling register_restart_file
integer :: thread_r, form
logical :: module_is_initialized = .FALSE.
character(len=128):: error_msg
logical :: great_circle_algorithm=.FALSE.
!------ private data, pointer to current 2d domain ------
! entrained from fms_mod. This will be deprecated in the future.
type(domain2D), pointer, private :: Current_domain =>NULL()
integer, private :: is,ie,js,je ! compute domain
integer, private :: isd,ied,jsd,jed ! data domain
integer, private :: isg,ieg,jsg,jeg ! global domain
character(len=128), dimension(:), allocatable :: registered_file ! file names registered through register_restart_file
type(restart_file_type), dimension(:), allocatable :: files_read ! store files that are read through read_data
type(restart_file_type), dimension(:), allocatable, target :: files_write ! store files that are written through write_data
type(domain2d), dimension(max_domains), target, save :: array_domain
type(domain1d), dimension(max_domains), save :: domain_x, domain_y
public :: read_data, read_compressed, write_data, read_distributed
public :: fms_io_init, fms_io_exit, field_size, get_field_size
public :: open_namelist_file, open_restart_file, open_ieee32_file, close_file
public :: set_domain, nullify_domain, get_domain_decomp, return_domain
public :: open_file, open_direct_file
public :: get_restart_io_mode, get_tile_string, string
public :: get_mosaic_tile_grid, get_mosaic_tile_file, get_file_name, get_mosaic_tile_file_ug
public :: get_global_att_value, get_var_att_value
public :: file_exist, field_exist
public :: register_restart_field, register_restart_axis, save_restart, restore_state
public :: set_meta_global
public :: save_restart_border, restore_state_border
public :: restart_file_type, query_initialized, set_initialized, free_restart_type
public :: reset_field_name, reset_field_pointer
private :: lookup_field_r, lookup_axis, unique_axes
public :: dimension_size
public :: set_filename_appendix, get_instance_filename
public :: get_filename_appendix, nullify_filename_appendix
public :: parse_mask_table
public :: get_great_circle_algorithm
public :: write_version_number
character(len=32), save :: filename_appendix = ''
!--- public interface ---
interface string
module procedure string_from_integer
module procedure string_from_real
end interface
!--- namelist interface
logical :: fms_netcdf_override = .true.
logical :: fms_netcdf_restart = .true.
character(len=32) :: threading_read = 'multi'
character(len=32) :: format = 'netcdf'
logical :: read_all_pe = .TRUE.
character(len=64) :: iospec_ieee32 = '-N ieee_32'
integer :: max_files_w = 40
integer :: max_files_r = 40
integer :: dr_set_size = 10
logical :: read_data_bug = .false.
logical :: time_stamp_restart = .true.
logical :: print_chksum = .false.
logical :: show_open_namelist_file_warning = .false.
logical :: debug_mask_list = .false.
logical :: checksum_required = .true.
namelist /fms_io_nml/ fms_netcdf_override, fms_netcdf_restart, &
threading_read, format, read_all_pe, iospec_ieee32,max_files_w,max_files_r, &
read_data_bug, time_stamp_restart, print_chksum, show_open_namelist_file_warning, &
debug_mask_list, checksum_required, dr_set_size
integer :: pack_size ! = 1 for double = 2 for float
! Include variable "version" to be written to log file.
#include<file_version.h>
!----------
!ug support
public :: fms_io_unstructured_register_restart_axis
public :: fms_io_unstructured_register_restart_field
public :: fms_io_unstructured_save_restart
public :: fms_io_unstructured_read
public :: fms_io_unstructured_get_field_size
public :: fms_io_unstructured_file_unit
public :: fms_io_unstructured_field_exist
interface fms_io_unstructured_register_restart_axis
module procedure fms_io_unstructured_register_restart_axis_r1D
module procedure fms_io_unstructured_register_restart_axis_i1D
module procedure fms_io_unstructured_register_restart_axis_u
end interface fms_io_unstructured_register_restart_axis
interface fms_io_unstructured_register_restart_field
module procedure fms_io_unstructured_register_restart_field_r_0d
module procedure fms_io_unstructured_register_restart_field_r_1d
module procedure fms_io_unstructured_register_restart_field_r_2d
module procedure fms_io_unstructured_register_restart_field_r_3d
#ifdef OVERLOAD_R8
module procedure fms_io_unstructured_register_restart_field_r8_2d
module procedure fms_io_unstructured_register_restart_field_r8_3d
#endif
module procedure fms_io_unstructured_register_restart_field_i_0d
module procedure fms_io_unstructured_register_restart_field_i_1d
module procedure fms_io_unstructured_register_restart_field_i_2d
end interface fms_io_unstructured_register_restart_field
interface fms_io_unstructured_read
module procedure fms_io_unstructured_read_r_scalar
module procedure fms_io_unstructured_read_r_1D
module procedure fms_io_unstructured_read_r_2D
module procedure fms_io_unstructured_read_r_3D
module procedure fms_io_unstructured_read_i_scalar
module procedure fms_io_unstructured_read_i_1D
module procedure fms_io_unstructured_read_i_2D
end interface fms_io_unstructured_read
!----------
contains
! <SUBROUTINE NAME="get_restart_io_mode">
! <DESCRIPTION>
! With the introduction of netCDF restart files, there is a need for a global
! switch to turn on/off netCDF restart options in all of the modules that deal with
! restart files. Here two more namelist variables (logical type) are introduced to fms_io
!
! fms_netcdf_override
! fms_netcdf_restart
!
! because default values of both flags are .true., the default behavior of the entire model is
! to use netCDF IO mode. To turn off netCDF restart, simply set fms_netcdf_restart to .false.
!
! </DESCRIPTION>
! <TEMPLATE>
! call get_fms_io_mode(do_netcdf_restart)
! </TEMPLATE>
! <INOUT NAME="do_netcdf_restart" TYPE="logical">
! This the input argument that contains the individual module setting of restart IO mode.
! Upon return from this subroutine, this output argument contains the actual setting of restart IO mode
! the calling module will be using
! </INOUT>
! </SUBROUTINE>
subroutine get_restart_io_mode(do_netcdf_restart)
logical, intent(inout) :: do_netcdf_restart
if(fms_netcdf_override) do_netcdf_restart = fms_netcdf_restart
end subroutine get_restart_io_mode
!.....................................................................
! <SUBROUTINE NAME="fms_io_init">
! <DESCRIPTION>
! Initialize fms_io module
! </DESCRIPTION>
! <TEMPLATE>
! call fms_io_init()
! </TEMPLATE>
subroutine fms_io_init()
integer :: i, unit, io_status, logunit
integer, allocatable, dimension(:) :: pelist
real(DOUBLE_KIND) :: doubledata = 0
real :: realarray(4)
character(len=256) :: grd_file, filename
logical :: is_mosaic_grid
character(len=4096) :: attvalue
if (module_is_initialized) return
call mpp_io_init()
#ifdef INTERNAL_FILE_NML
read (input_nml_file, fms_io_nml, iostat=io_status)
if (io_status > 0) then
call mpp_error(FATAL,'=>fms_io_init: Error reading input.nml')
endif
#else
call mpp_open(unit, 'input.nml',form=MPP_ASCII,action=MPP_RDONLY)
read(unit,fms_io_nml,iostat=io_status)
if (io_status > 0) then
call mpp_error(FATAL,'=>fms_io_init: Error reading input.nml')
endif
call mpp_close (unit)
#endif
! take namelist options if present
! determine packsize
pack_size = size(transfer(doubledata, realarray))
if( pack_size .NE. 1 .AND. pack_size .NE. 2) call mpp_error(FATAL,'=>fms_io_init: pack_size should be 1 or 2')
select case (threading_read)
case ('multi')
thread_r = MPP_MULTI
case ('single')
thread_r = MPP_SINGLE
case default
call mpp_error(FATAL,'fms_io_init: threading_read should be multi/single but you chose'//trim(threading_read))
end select
! take namelist options if present
select case(format)
case ('netcdf')
form=MPP_NETCDF
case default
call mpp_error(FATAL,'fms_io_init: only NetCDF format currently supported in fms_io')
end select
! Initially allocate files_write and files_read
allocate(files_write(max_files_w),files_read(max_files_r))
allocate(registered_file(max_files_w))
do i = 1, max_domains
array_domain(i) = NULL_DOMAIN2D
enddo
!---- initialize module domain2d pointer ----
nullify (Current_domain)
!This is set here instead of at the end of the routine to prevent the read_data call below from stopping the model
module_is_initialized = .TRUE.
! Record the version number in the log file
call write_version_number("FMS_IO_MOD", version)
!--- read INPUT/grid_spec.nc to decide the value of great_circle_algorithm
!--- great_circle_algorithm could be true only for mosaic grid.
great_circle_algorithm = .false.
grd_file = "INPUT/grid_spec.nc"
is_mosaic_grid = .FALSE.
if (file_exist(grd_file)) then
if(field_exist(grd_file, 'atm_mosaic_file')) then ! coupled grid
is_mosaic_grid = .TRUE.
else if(field_exist(grd_file, "gridfiles")) then
call read_data(grd_file, "gridfiles", filename, level=1)
grd_file = 'INPUT/'//trim(filename)
is_mosaic_grid = .TRUE.
endif
endif
if(is_mosaic_grid) then
if( get_global_att_value(grd_file, "great_circle_algorithm", attvalue) ) then
if(trim(attvalue) == "TRUE") then
great_circle_algorithm = .true.
else if(trim(attvalue) == "FALSE") then
great_circle_algorithm = .false.
else
call mpp_error(FATAL, "fms_io(fms_io_init: value of global attribute great_circle_algorithm in file"// &
trim(grd_file)//" should be TRUE of FALSE")
endif
endif
endif
if(great_circle_algorithm .AND. (mpp_pe() == mpp_root_pe()) ) then
call mpp_error(NOTE,"fms_io_mod: great_circle algorithm will be used in the model run")
endif
end subroutine fms_io_init
! </SUBROUTINE>
! <SUBROUTINE NAME="fms_io_exit">
! <DESCRIPTION>
! This routine is called after ALL fields have been written to temporary files
! The result NETCDF files are created here.
! </DESCRIPTION>
! <TEMPLATE>
! call fms_io_exit
! </TEMPLATE>
subroutine fms_io_exit()
integer :: num_x_axes, num_y_axes, num_z_axes
integer :: unit
real, dimension(max_axis_size) :: axisdata
real :: tlev
integer, dimension(max_axes) :: id_x_axes, siz_x_axes
integer, dimension(max_axes) :: id_y_axes, siz_y_axes
integer, dimension(max_axes) :: id_z_axes, siz_z_axes
type(axistype), dimension(max_axes) :: x_axes, y_axes, z_axes
type(axistype) :: t_axes
type(var_type), pointer, save :: cur_var=>NULL()
integer :: i, j, k, kk
character(len=256) :: filename
character(len=10) :: axisname
logical :: domain_present
logical :: write_on_this_pe
type(domain2d), pointer :: io_domain =>NULL()
if( .NOT.module_is_initialized )return !make sure it's only called once per PE
do i=1,max_axis_size
axisdata(i) = i
enddo
! each field has an associated domain type (may be undefined).
! each file only needs to write unique axes (i.e. if 2 fields share an identical axis, then only write the axis once)
! unique axes are defined by the global size and domain decomposition (i.e. can support identical axis sizes with
! different domain decomposition)
do i = 1, num_files_w
filename = files_write(i)%name
!--- check if any field in this file present domain.
domain_present = .false.
do j = 1, files_write(i)%nvar
if (files_write(i)%var(j)%domain_present) then
domain_present = .true.
exit
end if
end do
!--- get the unique axes for all the fields.
num_x_axes = unique_axes(files_write(i), 1, id_x_axes, siz_x_axes, domain_x)
num_y_axes = unique_axes(files_write(i), 2, id_y_axes, siz_y_axes, domain_y)
num_z_axes = unique_axes(files_write(i), 3, id_z_axes, siz_z_axes )
if( domain_present ) then
call mpp_open(unit,trim(filename),action=MPP_OVERWR,form=form, &
is_root_pe=files_write(i)%is_root_pe, domain=array_domain(files_write(i)%var(j)%domain_idx))
else ! global data
call mpp_open(unit,trim(filename),action=MPP_OVERWR,form=form,threading=MPP_SINGLE,&
fileset=MPP_SINGLE, is_root_pe=files_write(i)%is_root_pe)
end if
write_on_this_pe = .false.
if(domain_present) then
io_domain => mpp_get_io_domain(array_domain(files_write(i)%var(j)%domain_idx))
if(associated(io_domain)) then
if(mpp_domain_is_tile_root_pe(io_domain)) write_on_this_pe = .true.
endif
endif
!--- always write out from root pe
if( files_write(i)%is_root_pe ) write_on_this_pe = .true.
do j = 1, num_x_axes
if (j < 10) then
write(axisname,'(a,i1)') 'xaxis_',j
else
write(axisname,'(a,i2)') 'xaxis_',j
endif
if(id_x_axes(j) > 0) then
call mpp_write_meta(unit,x_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_x_axes(j)),domain=domain_x(id_x_axes(j)),cartesian='X')
else
call mpp_write_meta(unit,x_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_x_axes(j)),cartesian='X')
endif
end do
do j = 1, num_y_axes
if (j < 10) then
write(axisname,'(a,i1)') 'yaxis_',j
else
write(axisname,'(a,i2)') 'yaxis_',j
endif
if(id_y_axes(j) > 0) then
call mpp_write_meta(unit,y_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_y_axes(j)),domain=domain_y(id_y_axes(j)),cartesian='Y')
else
call mpp_write_meta(unit,y_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_y_axes(j)),cartesian='Y')
endif
end do
do j = 1, num_z_axes
if (j < 10) then
write(axisname,'(a,i1)') 'zaxis_',j
else
write(axisname,'(a,i2)') 'zaxis_',j
endif
call mpp_write_meta(unit,z_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_z_axes(j)),cartesian='Z')
end do
! write time axis (comment out if no time axis)
call mpp_write_meta(unit,t_axes,&
'Time','time level','Time',cartesian='T')
! write metadata for fields
do j = 1, files_write(i)%nvar
cur_var => files_write(i)%var(j)
call mpp_write_meta(unit,cur_var%field, (/x_axes(cur_var%id_axes(1)), &
y_axes(cur_var%id_axes(2)), z_axes(cur_var%id_axes(3)), t_axes/), cur_var%name, &
'none',cur_var%name,pack=pack_size)
enddo
! write values for ndim of spatial axes
do j = 1, num_x_axes
call mpp_write(unit,x_axes(j))
enddo
do j = 1, num_y_axes
call mpp_write(unit,y_axes(j))
enddo
do j = 1, num_z_axes
call mpp_write(unit,z_axes(j))
enddo
! write data of each field
do k = 1, files_write(i)%max_ntime
do j = 1, files_write(i)%nvar
cur_var => files_write(i)%var(j)
tlev=k
! If some fields only have one time level, we do not need to write the second level, just keep
! the data missing.
! If some fields only have one time level, we just write out 0 to the other level
if(k > cur_var%siz(4)) then
cur_var%buffer(:,:,:,1) = 0.0
kk = 1
else
kk = k
end if
if(cur_var%domain_present) then
call mpp_write(unit, cur_var%field,array_domain(cur_var%domain_idx), cur_var%buffer(:,:,:,kk), tlev, &
default_data=cur_var%default_data)
else if (write_on_this_pe) then
call mpp_write(unit, cur_var%field, cur_var%buffer(:,:,:,kk), tlev)
end if
enddo ! end j loop
enddo ! end k loop
call mpp_close(unit)
enddo ! end i loop
!--- release the memory
do i = 1, num_files_w
do j = 1, files_write(i)%nvar
deallocate(files_write(i)%var(j)%buffer)
end do
end do
cur_var=>NULL()
module_is_initialized = .false.
num_files_w = 0
num_files_r = 0
end subroutine fms_io_exit
!.....................................................................
! </SUBROUTINE>
! <SUBROUTINE NAME="write_data">
!<DESCRIPTION>
! This subroutine performs writing "fieldname" to file "filename". All values of "fieldname"
! will be written to a temporary file. The final NETCDF file will be created only at a later step
! when the user calls fms_io_exit. Therefore, make sure that fms_io_exit is called after all
! fields have been written by this subroutine.
!</DESCRIPTION>
! <TEMPLATE>
! call write_data(filename, fieldname, data, domain)
! </TEMPLATE>
! <IN NAME="filename" TYPE="character" DIM="(*)">
! File name
! </IN>
! <IN NAME="fieldname" TYPE="character" DIM="(*)">
! Field name
! </IN>
! <IN NAME="data" TYPE="real">
! array containing data of fieldname
! </IN>
! <IN NAME="domain" TYPE="domain, optional">
! domain of fieldname
! </IN>
!=================================================================================
subroutine write_data_i3d_new(filename, fieldname, data, domain, &
no_domain, position, tile_count, data_default)
character(len=*), intent(in) :: filename, fieldname
integer, dimension(:,:,:), intent(in) :: data
type(domain2d), intent(in), optional :: domain
logical, intent(in), optional :: no_domain
integer, intent(in), optional :: position, tile_count, data_default
real :: default_data
default_data = TRANSFER(MPP_FILL_INT,default_data)
if(present(data_default)) default_data = real(data_default)
call write_data_3d_new(filename, fieldname, real(data), domain, &
no_domain, .false., position, tile_count, data_default=default_data)
end subroutine write_data_i3d_new
!.....................................................................
subroutine write_data_i2d_new(filename, fieldname, data, domain, &
no_domain, position, tile_count, data_default)
character(len=*), intent(in) :: filename, fieldname
integer, dimension(:,:), intent(in) :: data
type(domain2d), intent(in), optional :: domain
logical, intent(in), optional :: no_domain
integer, intent(in), optional :: position, tile_count, data_default
real :: default_data
default_data = TRANSFER(MPP_FILL_INT,default_data)
if(present(data_default)) default_data = real(data_default)
call write_data_2d_new(filename, fieldname, real(data), domain, &
no_domain, position, tile_count, data_default=default_data)
end subroutine write_data_i2d_new
!.....................................................................
subroutine write_data_i1d_new(filename, fieldname, data, domain, &
no_domain, tile_count, data_default)
type(domain2d), intent(in), optional :: domain
character(len=*), intent(in) :: filename, fieldname
integer, dimension(:), intent(in) :: data
logical, intent(in), optional :: no_domain
integer, intent(in), optional :: tile_count, data_default
real :: default_data
default_data = TRANSFER(MPP_FILL_INT,default_data)
if(present(data_default)) default_data = real(data_default)
call write_data_1d_new(filename, fieldname, real(data), domain, &
no_domain, tile_count, data_default=default_data)
end subroutine write_data_i1d_new
!.....................................................................
subroutine write_data_iscalar_new(filename, fieldname, data, domain, &
no_domain, tile_count, data_default)
type(domain2d), intent(in), optional :: domain
character(len=*), intent(in) :: filename, fieldname
integer, intent(in) :: data
logical, intent(in), optional :: no_domain
integer, intent(in), optional :: tile_count, data_default
real :: default_data
default_data = TRANSFER(MPP_FILL_INT,default_data)
if(present(data_default)) default_data = real(data_default)
call write_data_scalar_new(filename, fieldname, real(data), domain, &
no_domain, tile_count, data_default=default_data)
end subroutine write_data_iscalar_new
!.....................................................................
subroutine write_data_3d_new(filename, fieldname, data, domain, no_domain, scalar_or_1d, &
position, tile_count, data_default)
character(len=*), intent(in) :: filename, fieldname
real, dimension(:,:,:), intent(in) :: data
type(domain2d), optional, intent(in), target :: domain
real, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
logical, optional, intent(in) :: scalar_or_1d
integer, optional, intent(in) :: position, tile_count
!--- local variables
real, allocatable :: tmp_buffer(:,:,:,:)
integer :: index_field ! position of the fieldname in the list of fields
integer :: index_file ! position of the filename in the list of files_write
logical :: append_pelist, is_no_domain, is_scalar_or_1d
character(len=256) :: fname, filename2,append_string
real :: default_data
integer :: length, i, domain_idx
integer :: ishift, jshift
integer :: gxsize, gysize
integer :: cxsize, cysize
integer :: dxsize, dysize
type(domain2d), pointer, save :: d_ptr =>NULL()
type(var_type), pointer, save :: cur_var =>NULL()
type(restart_file_type), pointer, save :: cur_file =>NULL()
! Initialize files to default values
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(write_data_3d_new): need to call fms_io_init')
if(PRESENT(data_default))then
default_data=data_default
else
default_data=MPP_FILL_DOUBLE
endif
if(present(tile_count) .AND. .not. present(domain)) call mpp_error(FATAL, &
'fms_io write_data: when tile_count is present, domain must be present')
is_scalar_or_1d = .false.
if(PRESENT(scalar_or_1d)) is_scalar_or_1d = scalar_or_1d
is_no_domain = .false.
if (PRESENT(no_domain)) THEN
is_no_domain = no_domain
end if
if(is_no_domain) then
if(PRESENT(domain)) &
call mpp_error(FATAL, 'fms_io(write_data_3d_new): no_domain cannot be .true. when optional argument domain is present.')
else if(PRESENT(domain))then
d_ptr => domain
else if (ASSOCIATED(Current_domain)) then
d_ptr => Current_domain
endif
!--- remove .nc from file name
length = len_trim(filename)
if(filename(length-2:length) == '.nc') then
filename2 = filename(1:length-3)
else
filename2 = filename(1:length)
end if
!Logical append_pelist decides whether to append the pelist_name to file name
append_pelist = .false.
!Append a string to the file name
append_string=''
!If the filename_appendix is set override the passed argument.
if(len_trim(filename_appendix) > 0) then
append_pelist = .true.
append_string = filename_appendix
endif
if(append_pelist) filename2 = trim(filename2)//'.'//trim(append_string)
!JWD: This is likely a temporary fix. Since fms_io needs to know tile_count,
!JWD: I just don't see how the physics can remain "tile neutral"
!z1l: one solution is add one more public interface called set_tile_count
call get_mosaic_tile_file(filename2, fname, is_no_domain, domain, tile_count)
! Check if filename has been open or not
index_file = -1
do i=1,num_files_w
if (trim(files_write(i)%name) == trim(fname)) then
index_file = i
cur_file => files_write(index_file)
exit
endif
enddo
if (index_file < 0) then
if(num_files_w == max_files_w) & ! need to have bigger max_files_w
call mpp_error(FATAL,'fms_io(write_data_3d_new): max_files_w exceeded, increase it via fms_io_nml')
! record the file name in array files_write
num_files_w=num_files_w + 1
index_file = num_files_w
cur_file => files_write(index_file)
cur_file%name = trim(fname)
cur_file%tile_count=1
if(present(tile_count)) cur_file%tile_count = tile_count
if(ASSOCIATED(d_ptr))then
cur_file%is_root_pe = mpp_domain_is_tile_root_pe(d_ptr)
else
cur_file%is_root_pe = mpp_pe() == mpp_root_pe()
endif
cur_file%max_ntime = 1
!-- allocate memory
allocate(cur_file%var(max_fields) )
cur_file%nvar = 0
do i = 1, max_fields
cur_file%var(i)%name = 'none'
cur_file%var(i)%domain_present = .false.
cur_file%var(i)%read_only = .false.
cur_file%var(i)%domain_idx = -1
cur_file%var(i)%is_dimvar = .false.
cur_file%var(i)%position = CENTER
cur_file%var(i)%siz(:) = 0
cur_file%var(i)%gsiz(:) = 0
cur_file%var(i)%id_axes(:) = -1
end do
endif
! check if the field is new or not and get position and dimension of the field
index_field = -1
do i = 1, cur_file%nvar
if(trim(cur_file%var(i)%name) == trim(fieldname)) then
index_field = i
exit
end if
end do
if(index_field > 0) then
cur_var => cur_file%var(index_field)
cur_var%siz(4) = cur_var%siz(4) + 1
if(cur_file%max_ntime < cur_var%siz(4) ) cur_file%max_ntime = cur_var%siz(4)
! the time level should be no larger than MAX_TIME_LEVEL_WRITE ( =20) for write_data.
if( cur_var%siz(4) > MAX_TIME_LEVEL_WRITE ) call mpp_error(FATAL, 'fms_io(write_data_3d_new): ' // &
'the time level of field '//trim(cur_var%name)//' in file '//trim(cur_file%name)// &
' is greater than MAX_TIME_LEVEL_WRITE(=20), increase MAX_TIME_LEVEL_WRITE or check your code')
else
cur_file%nvar = cur_file%nvar +1
if(cur_file%nvar>max_fields) then
write(error_msg,'(I3,"/",I3)') cur_file%nvar, max_fields
call mpp_error(FATAL,'fms_io(write_data_3d_new): max_fields exceeded, needs increasing, nvar/max_fields=' &
//trim(error_msg))
endif
index_field = cur_file%nvar
cur_var => cur_file%var(index_field)
cur_var%siz(1) = size(data,1)
cur_var%siz(2) = size(data,2)
cur_var%siz(3) = size(data,3)
cur_var%siz(4) = 1
cur_var%gsiz(3) = cur_var%siz(3)
cur_var%name = fieldname
cur_var%default_data = default_data
cur_var%ndim = 3
if(present(position)) cur_var%position = position
if(ASSOCIATED(d_ptr) .AND. .NOT. is_scalar_or_1d)then
cur_var%domain_present = .true.
domain_idx = lookup_domain(d_ptr)
if(domain_idx == -1) then
num_domains = num_domains + 1
if(num_domains > max_domains) call mpp_error(FATAL,'fms_io(write_data_3d_new), 1: max_domains exceeded,' &
//' needs increasing')
domain_idx = num_domains
array_domain(domain_idx) = d_ptr
call mpp_get_domain_components(array_domain(domain_idx), domain_x(domain_idx), domain_y(domain_idx), &
tile_count=tile_count)
endif
cur_var%domain_idx = domain_idx
call mpp_get_domain_shift ( array_domain(domain_idx), ishift, jshift, position)
call mpp_get_global_domain(array_domain(domain_idx), xsize=gxsize,ysize=gysize,tile_count=tile_count)
call mpp_get_compute_domain(array_domain(domain_idx), xsize = cxsize, ysize = cysize, tile_count=tile_count)
call mpp_get_data_domain (array_domain(domain_idx), xsize = dxsize, ysize = dysize, tile_count=tile_count)
if (ishift .NE. 0) then
cxsize = cxsize+ishift; dxsize = dxsize+ishift; gxsize = gxsize + ishift
end if
if (jshift .NE. 0) then
cysize = cysize+jshift; dysize = dysize+jshift; gysize = gysize + jshift
endif
if( (cur_var%siz(1) .NE. cxsize .AND. cur_var%siz(1) .NE. dxsize ) .OR. &
(cur_var%siz(2) .NE. cysize .AND. cur_var%siz(2) .NE. dysize ) ) then
call mpp_error(FATAL, 'fms_io(write_data_3d_new): data should be on either compute domain '//&
'or data domain when domain is present for field '//trim(fieldname)//' of file '//trim(filename) )
end if
cur_var%gsiz(1) = gxsize
cur_var%gsiz(2) = gysize
else
cur_var%domain_present=.false.
cur_var%gsiz(1) = size(data,1)
cur_var%gsiz(2) = size(data,2)
endif
end if
! copy the data to the buffer
! if the time level is greater than the size(cur_var%buffer,4),
! need to increase the buffer size
if(cur_var%siz(4) == 1) then
allocate(cur_var%buffer(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3), cur_var%siz(4)) )
else
allocate(tmp_buffer(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3), size(cur_var%buffer,4)) )
tmp_buffer = cur_var%buffer
deallocate(cur_var%buffer)
allocate(cur_var%buffer(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3), cur_var%siz(4)) )
cur_var%buffer(:,:,:,1:size(tmp_buffer,4)) = tmp_buffer
deallocate(tmp_buffer)
endif
cur_var%buffer(:,:,:,cur_var%siz(4)) = data ! copy current data to buffer for future write out
d_ptr =>NULL()
cur_var =>NULL()
cur_file =>NULL()
end subroutine write_data_3d_new
! </SUBROUTINE>
!-------------------------------------------------------------------------------
!
! This routine will register an integer restart file axis
!
!-------------------------------------------------------------------------------
subroutine register_restart_axis_r1d(fileObj,filename,fieldname,data,cartesian,units,longname,sense,min,calendar)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, intent(in), target :: data(:)
character(len=*), intent(in) :: cartesian
character(len=*), optional, intent(in) :: units, longname
integer, optional, intent(in) :: sense
real, optional, intent(in) :: min !valid min for real axis data
character(len=*), optional, intent(in) :: calendar
integer :: idx
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_axis_r1d): need to call fms_io_init')
select case(trim(cartesian))
case('X')
idx = XIDX
case('Y')
idx = YIDX
case('Z')
idx = ZIDX
case('T')
idx = TIDX
case('CC')
idx = CCIDX
case default
call mpp_error(FATAL,'fms_io(register_restart_axis_r1d): Axis must be one of X,Y,Z,T or CC ' // &
'but has value '//trim(cartesian))
end select
if(.not. ALLOCATED(fileObj%axes)) allocate(fileObj%axes(NIDX))
if(ASSOCIATED(fileObj%axes(idx)%data)) &
call mpp_error(FATAL,'fms_io(register_restart_axis_r1d): '//trim(cartesian)//' axis has already been defined')
!Why do we do this?
! fileObj%name = filename
fileObj%axes(idx)%name = fieldname
fileObj%axes(idx)%data =>data
fileObj%axes(idx)%cartesian = cartesian
fileObj%axes(idx)%dimlen = -1 ! This is not a compressed axis
if(PRESENT(units)) fileObj%axes(idx)%units = units
if(PRESENT(longname)) fileObj%axes(idx)%longname = longname
if(PRESENT(min)) fileObj%axes(idx)%min = min
if(idx == TIDX) then
if(PRESENT(calendar)) fileObj%axes(idx)%calendar = trim(calendar)
endif
if(PRESENT(sense)) then
if(idx /= ZIDX) call mpp_error(FATAL,'fms_io(register_restart_axis_r1d): Only the Z axis may define sense; ' // &
'Axis = '//trim(cartesian))
if(abs(sense) /= 1) call mpp_error(FATAL,'fms_io(register_restart_axis_r1d): Value of sense must be +/- 1')
fileObj%axes(idx)%sense = sense
endif
end subroutine register_restart_axis_r1d
!-------------------------------------------------------------------------------
!
! This routine will register the compressed index restart file axis
!
!-------------------------------------------------------------------------------
subroutine register_restart_axis_i1d(fileObj,filename,fieldname,data,compressed, &
compressed_axis,dimlen,dimlen_name,dimlen_lname,units,longname,imin)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
integer, intent(in) :: data(:)
character(len=*), intent(in) :: compressed
character(len=*), intent(in) :: compressed_axis !< which compressed axis (C or H)
integer, intent(in) :: dimlen
character(len=*), optional, intent(in) :: dimlen_name, dimlen_lname !< dimlen axis name and longname
character(len=*), optional, intent(in) :: units, longname
integer, optional, intent(in) :: imin !valid min for integer axis data
integer :: ssize,rsize,npes
integer :: idx
integer, allocatable :: pelist(:)
type(domain2d), pointer :: io_domain=>NULL()
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_axis_i1d): need to call fms_io_init')
select case(trim(compressed_axis))
case('C')
idx = CIDX
case('H')
idx = HIDX
case default
call mpp_error(FATAL,'fms_io(register_restart_axis_r1d): Axis must be one of C or H ' // &
'but has value '//trim(compressed_axis))
end select
if(.not. ALLOCATED(fileObj%axes)) allocate(fileObj%axes(NIDX))
if(ALLOCATED(fileObj%axes(idx)%idx)) &
call mpp_error(FATAL,'fms_io(register_restart_axis_i1d): Compressed axis ' //&
trim(compressed_axis) // ' has already been defined')
!Why do we do this?
! fileObj%name = filename
fileObj%is_compressed = .true.
fileObj%unlimited_axis = .false.
fileObj%axes(idx)%name = fieldname
if(ASSOCIATED(current_domain)) then
fileObj%axes(idx)%domain =>current_domain
io_domain =>mpp_get_io_domain(current_domain)
if(.not. ASSOCIATED(io_domain)) &
call mpp_error(FATAL,'fms_io(register_restart_axis_i1d): The io domain must be defined')
npes = mpp_get_domain_npes(io_domain)
allocate(fileObj%axes(idx)%nelems(npes)); fileObj%axes(idx)%nelems = 0
allocate(pelist(npes))
call mpp_get_pelist(io_domain,pelist)
ssize = size(data)
call mpp_gather((/ssize/),fileObj%axes(idx)%nelems,pelist)
rsize = sum(fileObj%axes(idx)%nelems)
allocate( fileObj%axes(idx)%idx(rsize) )
! Note that the gatherV implied here is asymmetric; only root needs to know the vector of recv sizes
call mpp_gather(data,ssize,fileObj%axes(idx)%idx,fileObj%axes(idx)%nelems,pelist)
deallocate(pelist); io_domain=>NULL()
else
call mpp_error(FATAL,'fms_io(register_restart_axis_i1d): The domain must be defined through set_domain')
endif
fileObj%axes(idx)%compressed = compressed
fileObj%axes(idx)%dimlen = dimlen
if(PRESENT(dimlen_name)) fileObj%axes(idx)%dimlen_name = dimlen_name
if(PRESENT(dimlen_lname)) fileObj%axes(idx)%dimlen_lname = dimlen_lname
if(PRESENT(units)) fileObj%axes(idx)%units = units
if(PRESENT(longname)) fileObj%axes(idx)%longname = longname
if(PRESENT(imin)) fileObj%axes(idx)%imin = imin
end subroutine register_restart_axis_i1d
!-------------------------------------------------------------------------------
subroutine register_restart_axis_unlimited(fileObj,filename,fieldname,nelem,units,longname)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
integer :: nelem ! Number of elements on rank
character(len=*), optional, intent(in) :: units, longname
integer :: idx,npes
integer, allocatable :: pelist(:)
type(domain2d), pointer :: io_domain=>NULL()
if(.not.module_is_initialized) &
call mpp_error(FATAL,'fms_io(register_restart_axis_unlimited): need to call fms_io_init')
idx = UIDX
if(.not. ALLOCATED(fileObj%axes)) allocate(fileObj%axes(NIDX))
if(ALLOCATED(fileObj%axes(idx)%idx)) &
call mpp_error(FATAL,'fms_io(register_restart_axis_unlimited): Unlimited axis has already been defined')
!Why do we do this?
! fileObj%name = filename
fileObj%is_compressed = .false.
fileObj%unlimited_axis = .true.
fileObj%axes(idx)%name = fieldname
if(ASSOCIATED(current_domain)) then
fileObj%axes(idx)%domain =>current_domain
io_domain =>mpp_get_io_domain(current_domain)
if(.not. ASSOCIATED(io_domain)) &
call mpp_error(FATAL,'fms_io(register_restart_axis_i1d): The io domain must be defined')
npes = mpp_get_domain_npes(io_domain)
allocate(fileObj%axes(idx)%nelems(npes)); fileObj%axes(idx)%nelems = 0
allocate(pelist(npes))
call mpp_get_pelist(io_domain,pelist)
call mpp_gather((/nelem/),fileObj%axes(idx)%nelems,pelist)
deallocate(pelist); io_domain=>NULL()
else
call mpp_error(FATAL,'fms_io(register_restart_axis_unlimited): The domain must be defined through set_domain')
endif
if(PRESENT(units)) fileObj%axes(idx)%units = units
if(PRESENT(longname)) fileObj%axes(idx)%longname = longname
end subroutine register_restart_axis_unlimited
!
! This routine is the destructor for the file object
!
!-------------------------------------------------------------------------------
subroutine free_restart_type(fileObj)
type(restart_file_type), intent(inout) :: fileObj
type(meta_type),pointer :: this
type(meta_type),pointer :: this_p
integer :: id, n, j, k
!--- remove file name from registered_file
id = 0
do n = 1, num_registered_files
if( trim(fileObj%name) == trim(registered_file(n)) ) then
id = n
exit
endif
enddo
if( id < 0) &
call mpp_error(FATAL, 'fms_io(free_restart_type): fileObj%name is not found in registered_files')
do n = id+1, num_registered_files
registered_file(n-1) = trim(registered_file(n))
enddo
registered_file(num_registered_files) = ''
num_registered_files = num_registered_files - 1
fileObj%register_id = 0
fileObj%unit = -1
fileObj%name = ''
fileObj%nvar = -1
fileObj%natt = -1
fileObj%max_ntime = -1
fileObj%tile_count = -1
if(ALLOCATED(fileObj%axes)) deallocate(fileObj%axes)
! deallocate all the data that restart owns
do k = 1,size(fileObj%var)
if (fileObj%var(k)%owns_data) then
do j = 1,size(fileObj%p0dr,1)
if(ASSOCIATED(fileObj%p0dr(j,k)%p)) deallocate(fileObj%p0dr(j,k)%p)
if(ASSOCIATED(fileObj%p1dr(j,k)%p)) deallocate(fileObj%p1dr(j,k)%p)
if(ASSOCIATED(fileObj%p2dr(j,k)%p)) deallocate(fileObj%p2dr(j,k)%p)
if(ASSOCIATED(fileObj%p3dr(j,k)%p)) deallocate(fileObj%p3dr(j,k)%p)
if(ASSOCIATED(fileObj%p2dr8(j,k)%p)) deallocate(fileObj%p2dr8(j,k)%p)
if(ASSOCIATED(fileObj%p3dr8(j,k)%p)) deallocate(fileObj%p3dr8(j,k)%p)
if(ASSOCIATED(fileObj%p0di(j,k)%p)) deallocate(fileObj%p0di(j,k)%p)
if(ASSOCIATED(fileObj%p1di(j,k)%p)) deallocate(fileObj%p1di(j,k)%p)
if(ASSOCIATED(fileObj%p2di(j,k)%p)) deallocate(fileObj%p2di(j,k)%p)
if(ASSOCIATED(fileObj%p3di(j,k)%p)) deallocate(fileObj%p3di(j,k)%p)
enddo
endif
enddo
if(ASSOCIATED(fileObj%var)) deallocate(fileObj%var)
if(ASSOCIATED(fileObj%p0dr)) deallocate(fileObj%p0dr)
if(ASSOCIATED(fileObj%p1dr)) deallocate(fileObj%p1dr)
if(ASSOCIATED(fileObj%p2dr)) deallocate(fileObj%p2dr)
if(ASSOCIATED(fileObj%p3dr)) deallocate(fileObj%p3dr)
if(ASSOCIATED(fileObj%p2dr8)) deallocate(fileObj%p2dr8)
if(ASSOCIATED(fileObj%p3dr8)) deallocate(fileObj%p3dr8)
if(ASSOCIATED(fileObj%p0di)) deallocate(fileObj%p0di)
if(ASSOCIATED(fileObj%p1di)) deallocate(fileObj%p1di)
if(ASSOCIATED(fileObj%p2di)) deallocate(fileObj%p2di)
if(ASSOCIATED(fileObj%p3di)) deallocate(fileObj%p3di)
if(ASSOCIATED(fileObj%first)) then
this =>fileObj%first
do while(associated(this%next))
this =>this%next ! Find the last element
enddo
do while(associated(this)) ! Deallocate from the last element to the first
this_p =>this%prev
!!$ Gfortran on gaea does not yet support deferred length character strings
!!$ deallocate(this%name)
this%name='' ! Remove this line when Gfortran supports deferred length character strings
if(allocated(this%rval)) deallocate(this%rval)
if(allocated(this%ival)) deallocate(this%ival)
!!$ Gfortran on gaea does not yet support deferred length character strings
!!$ if(allocated(this%cval)) deallocate(this%cval)
this%cval='' ! Remove this line when Gfortran supports deferred length character strings
deallocate(this)
this =>this_p
enddo
fileObj%first =>NULL()
endif
end subroutine free_restart_type
!-------------------------------------------------------------------------------
!
! The routine sets up a list of global metadata expressions for save_restart
!
!-------------------------------------------------------------------------------
subroutine set_meta_global(fileObj, name, rval, ival, cval)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: name
real, intent(in), optional :: rval(:)
integer, intent(in), optional :: ival(:)
character(len=*), intent(in), optional :: cval
type(meta_type),pointer :: this
type(meta_type),pointer :: this_n
this =>fileObj%first
if(associated(this))then
do while(associated(this%next))
this =>this%next
enddo
allocate(this_n); this%next =>this_n; this_n%prev =>this; this =>this_n
else
allocate(this)
fileObj%first =>this
endif
! Per mpp_write_meta_global, only one type of data can be associated with the metadata
!!$ Gfortran on gaea does not yet support deferred length character strings
!!$ allocate(character(len(name)) :: this%name); this%name = name
this%name = name ! Remove this line when Gfortran supports deferred length character stings
if(present(rval))then
allocate(this%rval(size(rval))); this%rval=rval
elseif(present(ival))then
allocate(this%ival(size(ival))); this%ival=ival
elseif(present(cval))then
!!$ Gfortran on gaea does not yet support deferred length character strings
!!$ allocate(character(len(cval)) :: this%cval); this%cval = cval
this%cval=cval ! Remove this line when Gfortran supports deferred length character stings
endif
end subroutine set_meta_global
!-------------------------------------------------------------------------------
!
! The routine writes the global metadata
!
!-------------------------------------------------------------------------------
subroutine write_meta_global(unit,fileObj)
integer, intent(in) :: unit
type(restart_file_type), intent(in) :: fileObj
type(meta_type), pointer :: this
this =>fileObj%first
do while(associated(this))
if(allocated(this%rval))then
call mpp_write_meta(unit,this%name,rval=this%rval)
elseif(allocated(this%ival))then
call mpp_write_meta(unit,this%name,ival=this%ival)
!!$ Gfortran on gaea does not yet support deferred length character strings
!!$ elseif(allocated(this%cval))then
elseif(len_trim(this%cval).GT.0)then ! Remove this line when Gfortran supports deferred length character stings
call mpp_write_meta(unit,this%name,cval=this%cval)
else
call mpp_write_meta(unit,this%name)
endif
this =>this%next
enddo
end subroutine write_meta_global
!-------------------------------------------------------------------------------
!
! The routine will register a scalar real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r0d(fileObj, filename, fieldname, data, domain, mandatory, &
no_domain, position, tile_count, data_default, &
longname, units, read_only, restart_owns_data)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, intent(in), target :: data
type(domain2d), optional, intent(in), target :: domain
logical, optional, intent(in) :: no_domain
real, optional, intent(in) :: data_default
logical, optional, intent(in) :: mandatory
integer, optional, intent(in) :: position, tile_count
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: restart_owns_data
integer :: index_field
integer :: register_restart_field_r0d
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_r0d): need to call fms_io_init')
call setup_one_field(fileObj, filename, fieldname, (/1, 1, 1, 1/), index_field, domain, mandatory, &
no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
data_default=data_default, longname=longname, units=units, read_only=read_only,&
owns_data=restart_owns_data)
fileObj%p0dr(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 0
register_restart_field_r0d = index_field
end function register_restart_field_r0d
!-------------------------------------------------------------------------------
!
! The routine will register a 1-D real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r1d(fileObj, filename, fieldname, data, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, &
compressed_axis, read_only, restart_owns_data)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, dimension(:), intent(in), target :: data
type(domain2d), optional, intent(in), target :: domain
logical, optional, intent(in) :: no_domain
real, optional, intent(in) :: data_default
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units, compressed_axis
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: restart_owns_data
integer :: index_field
integer :: register_restart_field_r1d
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_r1d): need to call fms_io_init')
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), 1, 1, 1/), index_field, domain, mandatory, &
no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
data_default=data_default, longname=longname, units=units, compressed_axis=compressed_axis, &
read_only=read_only, owns_data=restart_owns_data)
fileObj%p1dr(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 1
register_restart_field_r1d = index_field
end function register_restart_field_r1d
!-------------------------------------------------------------------------------
!
! The routine will register a 2-D real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r2d(fileObj, filename, fieldname, data, domain, mandatory, no_domain, &
compressed, position, tile_count, data_default, longname, units, &
compressed_axis, read_only, restart_owns_data)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, dimension(:,:), intent(in), target :: data
type(domain2d), optional, intent(in), target :: domain
real, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
logical, optional, intent(in) :: compressed
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units, compressed_axis
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: restart_owns_data
logical :: is_compressed
integer :: index_field
integer :: register_restart_field_r2d
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_r2d): need to call fms_io_init')
is_compressed = .false.
if(present(compressed)) is_compressed=compressed
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), 1, 1/), &
index_field, domain, mandatory, no_domain, is_compressed, &
position, tile_count, data_default, longname, units, compressed_axis, &
read_only=read_only, owns_data=restart_owns_data)
fileObj%p2dr(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 2
register_restart_field_r2d = index_field
end function register_restart_field_r2d
!-------------------------------------------------------------------------------
!
! The routine will register a 3-D real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r3d(fileObj, filename, fieldname, data, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only, &
compressed, compressed_axis, restart_owns_data)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, dimension(:,:,:), intent(in), target :: data
type(domain2d), optional, intent(in), target :: domain
real, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units, compressed_axis
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: compressed
logical, optional, intent(in) :: restart_owns_data
logical :: is_compressed
integer :: index_field
integer :: register_restart_field_r3d
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_r3d): need to call fms_io_init')
if(present(compressed)) then
is_compressed=compressed
else
is_compressed = .false.
endif
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), size(data,3), 1/), &
index_field, domain, mandatory, no_domain, is_compressed, &
position, tile_count, data_default, longname, units, compressed_axis, &
read_only=read_only, owns_data=restart_owns_data)
fileObj%p3dr(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 3
register_restart_field_r3d = index_field
end function register_restart_field_r3d
#ifdef OVERLOAD_R8
!-------------------------------------------------------------------------------
!
! The routine will register a 2-D double_kind restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r2d8(fileObj, filename, fieldname, data, domain, mandatory, no_domain, &
compressed, position, tile_count, data_default, longname, units, &
compressed_axis, read_only, restart_owns_data)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real(DOUBLE_KIND), dimension(:,:), intent(in), target :: data
type(domain2d), optional, intent(in), target :: domain
real(DOUBLE_KIND), optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
logical, optional, intent(in) :: compressed
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units, compressed_axis
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: restart_owns_data
logical :: is_compressed
integer :: index_field
integer :: register_restart_field_r2d8
real(FLOAT_KIND) :: data_default_r4
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_r2d8): need to call fms_io_init')
is_compressed = .false.
if(present(compressed)) is_compressed=compressed
if(present(data_default)) then
data_default_r4=REAL(data_default, FLOAT_KIND)
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), 1, 1/), &
index_field, domain, mandatory, no_domain, is_compressed, &
position, tile_count, data_default_r4, longname, units, compressed_axis, &
read_only=read_only, owns_data=restart_owns_data)
else
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), 1, 1/), &
index_field, domain, mandatory, no_domain, is_compressed, &
position, tile_count, longname=longname, units=units, compressed_axis=compressed_axis, &
read_only=read_only, owns_data=restart_owns_data)
endif
fileObj%p2dr8(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 2
register_restart_field_r2d8 = index_field
end function register_restart_field_r2d8
!-------------------------------------------------------------------------------
!
! The routine will register a 3-D double_kind restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r3d8(fileObj, filename, fieldname, data, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only, &
compressed, compressed_axis, restart_owns_data)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real(DOUBLE_KIND), dimension(:,:,:), intent(in), target :: data
type(domain2d), optional, intent(in), target :: domain
real(DOUBLE_KIND), optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units, compressed_axis
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: compressed
logical, optional, intent(in) :: restart_owns_data
logical :: is_compressed
integer :: index_field
integer :: register_restart_field_r3d8
real(FLOAT_KIND) :: data_default_r4
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_r3d8): need to call fms_io_init')
is_compressed = .false.
if(present(compressed)) is_compressed=compressed
if(present(data_default)) then
data_default_r4=REAL(data_default, FLOAT_KIND)
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), size(data,3), 1/), &
index_field, domain, mandatory, no_domain, is_compressed, &
position, tile_count, data_default_r4, longname, units, compressed_axis, &
read_only=read_only, owns_data=restart_owns_data)
else
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), size(data,3), 1/), &
index_field, domain, mandatory, no_domain, is_compressed, &
position, tile_count, longname=longname, units=units, compressed_axis=compressed_axis, &
read_only=read_only, owns_data=restart_owns_data)
endif
fileObj%p3dr8(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 3
register_restart_field_r3d8 = index_field
end function register_restart_field_r3d8
#endif
!-------------------------------------------------------------------------------
!
! The routine will register a 4-D real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r4d(fileObj, filename, fieldname, data, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, &
read_only, restart_owns_data)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, dimension(:,:,:,:), intent(in), target :: data
type(domain2d), optional, intent(in), target :: domain
real, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: restart_owns_data
integer :: index_field
integer :: register_restart_field_r4d
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_r4d): need to call fms_io_init')
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), size(data,3), 1, size(data,4)/), &
index_field, domain, mandatory, no_domain, .false., &
position, tile_count, data_default, longname, units, &
read_only=read_only, owns_data=restart_owns_data)
fileObj%p4dr(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 4
register_restart_field_r4d = index_field
end function register_restart_field_r4d
!-------------------------------------------------------------------------------
!
! The routine will register a scalar integer restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i0d(fileObj, filename, fieldname, data, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, &
read_only, restart_owns_data)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
integer, intent(in), target :: data
type(domain2d), optional, intent(in), target :: domain
integer, optional, intent(in) :: data_default
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
logical, optional, intent(in) :: no_domain
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: restart_owns_data
integer :: index_field
integer :: register_restart_field_i0d
real :: data_default_r
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_i0d): need to call fms_io_init')
if (KIND(data_default)/=KIND(data)) call mpp_error(FATAL,'fms_io(register_restart_field_i0d): data_default and data different KIND()')
data_default_r = TRANSFER(MPP_FILL_INT,data_default_r)
if (present(data_default)) data_default_r = TRANSFER(data_default ,data_default_r)
call setup_one_field(fileObj, filename, fieldname, (/1, 1, 1, 1/), index_field, domain, &
mandatory, no_domain=no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
data_default=data_default_r, longname=longname, units=units, &
read_only=read_only, owns_data=restart_owns_data)
fileObj%p0di(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 0
register_restart_field_i0d = index_field
end function register_restart_field_i0d
!-------------------------------------------------------------------------------
!
! The routine will register a 1-D integer restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i1d(fileObj, filename, fieldname, data, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, &
compressed_axis, read_only, restart_owns_data)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
integer, dimension(:), intent(in), target :: data
type(domain2d), optional, intent(in), target :: domain
integer, optional, intent(in) :: data_default
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
logical, optional, intent(in) :: no_domain
character(len=*), optional, intent(in) :: longname, units, compressed_axis
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: restart_owns_data
integer :: index_field
integer :: register_restart_field_i1d
real :: data_default_r
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_i1d): need to call fms_io_init')
if (KIND(data_default)/=KIND(data)) call mpp_error(FATAL,'fms_io(register_restart_field_i1d): data_default and data different KIND()')
data_default_r = TRANSFER(MPP_FILL_INT,data_default_r)
if (present(data_default)) data_default_r = TRANSFER(data_default ,data_default_r)
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), 1, 1, 1/), index_field, domain, &
mandatory, no_domain=no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
data_default=data_default_r, longname=longname, units=units, compressed_axis=compressed_axis, &
read_only=read_only, owns_data=restart_owns_data)
fileObj%p1di(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 1
register_restart_field_i1d = index_field
end function register_restart_field_i1d
!-------------------------------------------------------------------------------
!
! The routine will register a 2-D real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i2d(fileObj, filename, fieldname, data, domain, mandatory, no_domain, &
compressed, position, tile_count, data_default, longname, units, &
compressed_axis, read_only, restart_owns_data)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
integer, dimension(:,:), intent(in), target :: data
type(domain2d), optional, intent(in), target :: domain
integer, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
logical, optional, intent(in) :: compressed
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units, compressed_axis
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: restart_owns_data
logical :: is_compressed
integer :: index_field
integer :: register_restart_field_i2d
real :: data_default_r
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_i2d): need to call fms_io_init')
is_compressed = .false.
if(present(compressed)) is_compressed=compressed
if (KIND(data_default)/=KIND(data)) call mpp_error(FATAL,'fms_io(register_restart_field_i2d): data_default and data different KIND()')
data_default_r = TRANSFER(MPP_FILL_INT,data_default_r)
if (present(data_default)) data_default_r = TRANSFER(data_default ,data_default_r)
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), 1, 1/), &
index_field, domain, mandatory, no_domain, is_compressed, &
position, tile_count, data_default_r, longname, units, compressed_axis, &
read_only=read_only, owns_data=restart_owns_data)
fileObj%p2di(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 2
register_restart_field_i2d = index_field
end function register_restart_field_i2d
!-------------------------------------------------------------------------------
!
! The routine will register a 3-D real restart file field with one time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i3d(fileObj, filename, fieldname, data, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, &
read_only, restart_owns_data)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
integer, dimension(:,:,:), intent(in), target :: data
type(domain2d), optional, intent(in), target :: domain
integer, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: restart_owns_data
integer :: index_field
integer :: register_restart_field_i3d
real :: data_default_r
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_field_i3d): need to call fms_io_init')
if (KIND(data_default)/=KIND(data)) call mpp_error(FATAL,'fms_io(register_restart_field_i3d): data_default and data different KIND()')
data_default_r = TRANSFER(MPP_FILL_INT,data_default_r)
if (present(data_default)) data_default_r = TRANSFER(data_default ,data_default_r)
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), size(data,3), 1/), &
index_field, domain, mandatory, no_domain, .false., &
position, tile_count, data_default_r, longname, units, &
read_only=read_only, owns_data=restart_owns_data)
fileObj%p3di(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 3
register_restart_field_i3d = index_field
end function register_restart_field_i3d
!-------------------------------------------------------------------------------
!
! The routine will register a scalar real restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r0d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, intent(in), target :: data1, data2
type(domain2d), optional, intent(in), target :: domain
real, optional, intent(in) :: data_default
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
logical, optional, intent(in) :: no_domain
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
integer :: index_field
integer :: register_restart_field_r0d_2level
if(.not.module_is_initialized) call mpp_error(FATAL, &
'fms_io(register_restart_field_r0d_2level): need to call fms_io_init')
call setup_one_field(fileObj, filename, fieldname, (/1, 1, 1, 2/), index_field, domain, &
mandatory, no_domain=no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
data_default=data_default, longname=longname, units=units, read_only=read_only)
fileObj%p0dr(1, index_field)%p => data1
fileObj%p0dr(2, index_field)%p => data2
fileObj%var(index_field)%ndim = 0
register_restart_field_r0d_2level = index_field
end function register_restart_field_r0d_2level
!-------------------------------------------------------------------------------
!
! The routine will register a 1-D real restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r1d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, dimension(:), intent(in), target :: data1, data2
type(domain2d), optional, intent(in), target :: domain
real, optional, intent(in) :: data_default
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
logical, optional, intent(in) :: no_domain
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
integer :: index_field
integer :: register_restart_field_r1d_2level
if(.not.module_is_initialized) call mpp_error(FATAL, &
'fms_io(register_restart_field_r1d_2level): need to call fms_io_init')
call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), 1, 1, 2/), index_field, domain, &
mandatory, no_domain=no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
data_default=data_default, longname=longname, units=units, read_only=read_only)
fileObj%p1dr(1, index_field)%p => data1
fileObj%p1dr(2, index_field)%p => data2
fileObj%var(index_field)%ndim = 1
register_restart_field_r1d_2level = index_field
return
end function register_restart_field_r1d_2level
!-------------------------------------------------------------------------------
!
! The routine will register a 3-D real restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r2d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, dimension(:,:), intent(in), target :: data1, data2
type(domain2d), optional, intent(in), target :: domain
real, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
integer :: index_field
integer :: register_restart_field_r2d_2level
if(.not.module_is_initialized) call mpp_error(FATAL, &
'fms_io(register_restart_field_r2d_2level): need to call fms_io_init')
call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), size(data1,2), 1, 2/), &
index_field, domain, mandatory, no_domain, .false., &
position, tile_count, data_default, longname, units, read_only=read_only)
fileObj%p2dr(1, index_field)%p => data1
fileObj%p2dr(2, index_field)%p => data2
fileObj%var(index_field)%ndim = 2
register_restart_field_r2d_2level = index_field
return
end function register_restart_field_r2d_2level
!-------------------------------------------------------------------------------
!
! The routine will register a 3-D real restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r3d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, dimension(:,:,:), intent(in), target :: data1, data2
type(domain2d), optional, intent(in), target :: domain
real, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
integer :: index_field
integer :: register_restart_field_r3d_2level
if(.not.module_is_initialized) call mpp_error(FATAL, &
'fms_io(register_restart_field_r3d_2level): need to call fms_io_init')
call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), size(data1,2), size(data1,3), 2/), &
index_field, domain, mandatory, no_domain, .false., &
position, tile_count, data_default, longname, units, read_only=read_only)
fileObj%p3dr(1, index_field)%p => data1
fileObj%p3dr(2, index_field)%p => data2
fileObj%var(index_field)%ndim = 3
register_restart_field_r3d_2level = index_field
return
end function register_restart_field_r3d_2level
#ifdef OVERLOAD_R8
!-------------------------------------------------------------------------------
!
! The routine will register a 2-D double_kind restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r2d8_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real(DOUBLE_KIND), dimension(:,:), intent(in), target :: data1, data2
type(domain2d), optional, intent(in), target :: domain
real, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
integer :: index_field
integer :: register_restart_field_r2d8_2level
if(.not.module_is_initialized) call mpp_error(FATAL, &
'fms_io(register_restart_field_r2d_2level): need to call fms_io_init')
call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), size(data1,2), 1, 2/), &
index_field, domain, mandatory, no_domain, .false., &
position, tile_count, data_default, longname, units, read_only=read_only)
fileObj%p2dr8(1, index_field)%p => data1
fileObj%p2dr8(2, index_field)%p => data2
fileObj%var(index_field)%ndim = 2
register_restart_field_r2d8_2level = index_field
return
end function register_restart_field_r2d8_2level
!-------------------------------------------------------------------------------
!
! The routine will register a 3-D double_kind restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_r3d8_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real(DOUBLE_KIND), dimension(:,:,:), intent(in), target :: data1, data2
type(domain2d), optional, intent(in), target :: domain
real, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
integer :: index_field
integer :: register_restart_field_r3d8_2level
if(.not.module_is_initialized) call mpp_error(FATAL, &
'fms_io(register_restart_field_r3d_2level): need to call fms_io_init')
call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), size(data1,2), size(data1,3), 2/), &
index_field, domain, mandatory, no_domain, .false., &
position, tile_count, data_default, longname, units, read_only=read_only)
fileObj%p3dr8(1, index_field)%p => data1
fileObj%p3dr8(2, index_field)%p => data2
fileObj%var(index_field)%ndim = 3
register_restart_field_r3d8_2level = index_field
return
end function register_restart_field_r3d8_2level
#endif
!-------------------------------------------------------------------------------
!
! The routine will register a scalar integer restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i0d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
integer, intent(in), target :: data1, data2
type(domain2d), optional, intent(in), target :: domain
integer, optional, intent(in) :: data_default
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
logical, optional, intent(in) :: no_domain
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
integer :: index_field
integer :: register_restart_field_i0d_2level
real :: data_default_r
if(.not.module_is_initialized) call mpp_error(FATAL, &
'fms_io(register_restart_field_i0d_2level): need to call fms_io_init')
if (KIND(data_default)/=KIND(data1)) call mpp_error(FATAL,'fms_io(register_restart_field_i0d_2level): data_default and data1 different KIND()')
if (KIND(data_default)/=KIND(data2)) call mpp_error(FATAL,'fms_io(register_restart_field_i0d_2level): data_default and data2 different KIND()')
data_default_r = TRANSFER(MPP_FILL_INT,data_default_r)
if (present(data_default)) data_default_r = TRANSFER(data_default ,data_default_r)
call setup_one_field(fileObj, filename, fieldname, (/1, 1, 1, 2/), index_field, domain, &
mandatory, no_domain=no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
data_default=data_default_r, longname=longname, units=units, read_only=read_only)
fileObj%p0di(1, index_field)%p => data1
fileObj%p0di(2, index_field)%p => data2
fileObj%var(index_field)%ndim = 0
register_restart_field_i0d_2level = index_field
return
end function register_restart_field_i0d_2level
!-------------------------------------------------------------------------------
!
! The routine will register a 1-D integer restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i1d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
integer, dimension(:), intent(in), target :: data1, data2
type(domain2d), optional, intent(in), target :: domain
integer, optional, intent(in) :: data_default
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
logical, optional, intent(in) :: no_domain
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
integer :: index_field
integer :: register_restart_field_i1d_2level
real :: data_default_r
if(.not.module_is_initialized) call mpp_error(FATAL, &
'fms_io(register_restart_field_i1d_2level): need to call fms_io_init')
if (KIND(data_default)/=KIND(data1)) call mpp_error(FATAL,'fms_io(register_restart_field_i1d_2level): data_default and data1 different KIND()')
if (KIND(data_default)/=KIND(data2)) call mpp_error(FATAL,'fms_io(register_restart_field_i1d_2level): data_default and data2 different KIND()')
data_default_r = TRANSFER(MPP_FILL_INT,data_default_r)
if (present(data_default)) data_default_r = TRANSFER(data_default ,data_default_r)
call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), 1, 1, 2/), index_field, domain, &
mandatory, no_domain=no_domain, scalar_or_1d=.true., position=position, tile_count=tile_count, &
data_default=data_default_r, longname=longname, units=units, read_only=read_only)
fileObj%p1di(1, index_field)%p => data1
fileObj%p1di(2, index_field)%p => data2
fileObj%var(index_field)%ndim = 1
register_restart_field_i1d_2level = index_field
return
end function register_restart_field_i1d_2level
!-------------------------------------------------------------------------------
!
! The routine will register a 2-D integer restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i2d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
integer, dimension(:,:), intent(in), target :: data1, data2
type(domain2d), optional, intent(in), target :: domain
integer, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
integer :: index_field
integer :: register_restart_field_i2d_2level
real :: data_default_r
if(.not.module_is_initialized) call mpp_error(FATAL, &
'fms_io(register_restart_field_i2d_2level): need to call fms_io_init')
if (KIND(data_default)/=KIND(data1)) call mpp_error(FATAL,'fms_io(register_restart_field_i2d_2level): data_default and data1 different KIND()')
if (KIND(data_default)/=KIND(data2)) call mpp_error(FATAL,'fms_io(register_restart_field_i2d_2level): data_default and data2 different KIND()')
data_default_r = TRANSFER(MPP_FILL_INT,data_default_r)
if (present(data_default)) data_default_r = TRANSFER(data_default ,data_default_r)
call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), size(data1,2), 1, 2/), &
index_field, domain, mandatory, no_domain, .false., &
position, tile_count, data_default_r, longname, units, read_only=read_only)
fileObj%p2di(1, index_field)%p => data1
fileObj%p2di(2, index_field)%p => data2
fileObj%var(index_field)%ndim = 2
register_restart_field_i2d_2level = index_field
return
end function register_restart_field_i2d_2level
!-------------------------------------------------------------------------------
!
! The routine will register a 3-D integer restart file field with two time level
!
!-------------------------------------------------------------------------------
function register_restart_field_i3d_2level(fileObj, filename, fieldname, data1, data2, domain, mandatory, &
no_domain, position, tile_count, data_default, longname, units, read_only)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
integer, dimension(:,:,:), intent(in), target :: data1, data2
type(domain2d), optional, intent(in), target :: domain
integer, optional, intent(in) :: data_default
logical, optional, intent(in) :: no_domain
integer, optional, intent(in) :: position, tile_count
logical, optional, intent(in) :: mandatory
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
integer :: index_field
integer :: register_restart_field_i3d_2level
real :: data_default_r
if(.not.module_is_initialized) call mpp_error(FATAL, &
'fms_io(register_restart_field_i3d_2level): need to call fms_io_init')
if (KIND(data_default)/=KIND(data1)) call mpp_error(FATAL,'fms_io(register_restart_field_i3d_2level): data_default and data1 different KIND()')
if (KIND(data_default)/=KIND(data2)) call mpp_error(FATAL,'fms_io(register_restart_field_i3d_2level): data_default and data2 different KIND()')
data_default_r = TRANSFER(MPP_FILL_INT,data_default_r)
if (present(data_default)) data_default_r = TRANSFER(data_default ,data_default_r)
call setup_one_field(fileObj, filename, fieldname, (/size(data1,1), size(data1,2), size(data1,3), 2/), &
index_field, domain, mandatory, no_domain, .false., &
position, tile_count, data_default_r, longname, units, read_only=read_only)
fileObj%p3di(1, index_field)%p => data1
fileObj%p3di(2, index_field)%p => data2
fileObj%var(index_field)%ndim = 3
register_restart_field_i3d_2level = index_field
return
end function register_restart_field_i3d_2level
!-------------------------------------------------------------------------------
!
! The routine will register a 2-D real for a generic region defined
! by the global_size variable.
!
!-------------------------------------------------------------------------------
function register_restart_region_r2d (fileObj, filename, fieldname, data, indices, global_size, &
pelist, is_root_pe, longname, units, position, &
x_halo, y_halo, ishift, jshift, read_only, mandatory)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, dimension(:,:), intent(in), target :: data
integer, dimension(:), intent(in) :: indices, global_size, pelist
logical, intent(in) :: is_root_pe
character(len=*), optional, intent(in) :: longname, units
integer, optional, intent(in) :: position, x_halo, y_halo, ishift, jshift
logical, optional, intent(in) :: read_only
logical, optional, intent(in) :: mandatory
integer :: index_field, l_position
integer :: register_restart_region_r2d
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_region_r2d): need to call fms_io_init')
if ((is_root_pe) .and. (.not.ANY(mpp_pe().eq.pelist))) call mpp_error(FATAL, &
'fms_io(register_restart_region_r2d) designated root_pe is not a member of pelist')
l_position = CENTER
if (present(position)) l_position = position
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), 1, 1/), &
index_field, no_domain=.true., position=l_position, longname=longname, units=units, &
read_only=read_only, mandatory=mandatory)
fileObj%p2dr(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 2
fileObj%var(index_field)%is = indices(1)
fileObj%var(index_field)%ie = indices(2)
fileObj%var(index_field)%js = indices(3)
fileObj%var(index_field)%je = indices(4)
fileObj%var(index_field)%gsiz(1) = global_size(1)
fileObj%var(index_field)%gsiz(2) = global_size(2)
fileObj%is_root_pe = is_root_pe
fileObj%var(index_field)%x_halo = 0
fileObj%var(index_field)%y_halo = 0
fileObj%var(index_field)%ishift = 0
fileObj%var(index_field)%jshift = 0
if (present(x_halo)) fileObj%var(index_field)%x_halo = x_halo
if (present(y_halo)) fileObj%var(index_field)%y_halo = y_halo
if (present(ishift)) fileObj%var(index_field)%ishift = ishift
if (present(jshift)) fileObj%var(index_field)%jshift = jshift
if (allocated(fileObj%var(index_field)%pelist)) deallocate(fileObj%var(index_field)%pelist)
if (allocated(fileObj%var(index_field)%pelist)) deallocate(fileObj%var(index_field)%pelist)
allocate(fileObj%var(index_field)%pelist(size(pelist)))
fileObj%var(index_field)%pelist = pelist
register_restart_region_r2d = index_field
return
end function register_restart_region_r2d
!-------------------------------------------------------------------------------
!
! The routine will register a 3-D real for a generic region defined
! by the global_size variable.
!
!-------------------------------------------------------------------------------
function register_restart_region_r3d (fileObj, filename, fieldname, data, indices, global_size, &
pelist, is_root_pe, longname, units, position, &
x_halo, y_halo, ishift, jshift, read_only, mandatory)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in) :: filename, fieldname
real, dimension(:,:,:), intent(in), target :: data
integer, dimension(:), intent(in) :: indices, global_size, pelist
logical, intent(in) :: is_root_pe
character(len=*), optional, intent(in) :: longname, units
logical, optional, intent(in) :: read_only
integer, optional, intent(in) :: position, x_halo, y_halo, ishift, jshift
logical, optional, intent(in) :: mandatory
integer :: index_field, l_position
integer :: register_restart_region_r3d
if(.not.module_is_initialized) call mpp_error(FATAL,'fms_io(register_restart_region_r3d): need to call fms_io_init')
if ((is_root_pe) .and. (.not.ANY(mpp_pe().eq.pelist))) call mpp_error(FATAL, &
'fms_io(register_restart_region_r3d) designated root_pe is not a member of pelist')
l_position = CENTER
if (present(position)) l_position = position
call setup_one_field(fileObj, filename, fieldname, (/size(data,1), size(data,2), size(data,3), 1/), &
index_field, no_domain=.true., position=l_position, longname=longname, units=units, &
read_only=read_only, mandatory=mandatory)
fileObj%p3dr(fileObj%var(index_field)%siz(4), index_field)%p => data
fileObj%var(index_field)%ndim = 3
fileObj%var(index_field)%is = indices(1)
fileObj%var(index_field)%ie = indices(2)
fileObj%var(index_field)%js = indices(3)
fileObj%var(index_field)%je = indices(4)
fileObj%var(index_field)%gsiz(1) = global_size(1)
fileObj%var(index_field)%gsiz(2) = global_size(2)
fileObj%var(index_field)%gsiz(3) = global_size(3)
fileObj%is_root_pe = is_root_pe
fileObj%var(index_field)%x_halo = 0
fileObj%var(index_field)%y_halo = 0
fileObj%var(index_field)%ishift = 0
fileObj%var(index_field)%jshift = 0
if (present(x_halo)) fileObj%var(index_field)%x_halo = x_halo
if (present(y_halo)) fileObj%var(index_field)%y_halo = y_halo
if (present(ishift)) fileObj%var(index_field)%ishift = ishift
if (present(jshift)) fileObj%var(index_field)%jshift = jshift
if (allocated(fileObj%var(index_field)%pelist)) deallocate(fileObj%var(index_field)%pelist)
allocate(fileObj%var(index_field)%pelist(size(pelist)))
fileObj%var(index_field)%pelist = pelist
register_restart_region_r3d = index_field
return
end function register_restart_region_r3d
!-------------------------------------------------------------------------------
!
! saves all registered variables to restart files. Those variables are set
! through register_restart_field
!
!-------------------------------------------------------------------------------
subroutine save_restart(fileObj, time_stamp, directory, append, time_level)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in), optional :: directory
character(len=*), intent(in), optional :: time_stamp
! Arguments:
! (in) directory - The directory where the restart file goes.
! (in) time_stamp - character format of the time of this restart file.
logical, intent(in), optional :: append
real, intent(in), optional :: time_level
character(len=256) :: dir
character(len=80) :: restartname ! The restart file name (no dir).
character(len=336) :: restartpath ! The restart file path (dir/file).
! This approach is taken rather than interface overloading in order to preserve
! use of the register_restart_field infrastructure
if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(save_restart): " // &
"restart_file_type data must be initialized by calling register_restart_field before using it")
dir = "RESTART"
if(present(directory)) dir = directory
restartname = fileObj%name
if(time_stamp_restart) then
if (PRESENT(time_stamp)) then
if(len_trim(restartname)+len_trim(time_stamp) > 79) call mpp_error(FATAL, "fms_io(save_restart): " // &
"Length of restart file name + time_stamp is greater than allowed character length of 79")
restartname = trim(time_stamp)//"."//trim(restartname)
endif
end if
if(len_trim(dir) > 0) then
if(len_trim(dir)+len_trim(restartname) > 335) call mpp_error(FATAL, "fms_io(save_restart): " // &
"Length of full restart path + file name is greater than allowed character length of 355")
restartpath = trim(dir)//"/"// trim(restartname)
else
restartpath = trim(restartname)
end if
if(fileObj%is_compressed .AND. ALLOCATED(fileObj%axes)) then
! fileObj%axes must also be allocated if the file contains compressed axes
! But will this always be true in the future?
call save_compressed_restart(fileObj,restartpath,append,time_level)
elseif(fileObj%unlimited_axis .AND. ALLOCATED(fileObj%axes)) then
call save_unlimited_axis_restart(fileObj,restartpath)
else
call save_default_restart(fileObj,restartpath)
endif
if(print_chksum) call write_chksum(fileObj, MPP_OVERWR)
end subroutine save_restart
!---- return true if all fields in fileObj is read only
function all_field_read_only(fileObj)
type(restart_file_type), intent(in) :: fileObj
logical :: all_field_read_only
integer :: j
all_field_read_only = .TRUE.
do j = 1, fileObj%nvar
if( .not. fileObj%var(j)%read_only) then
all_field_read_only = .FALSE.
exit
endif
enddo
return
end function all_field_read_only
!-------------------------------------------------------------------------------
!
! saves all registered variables to restart files. Those variables are set
! through register_restart_field
!
!-------------------------------------------------------------------------------
subroutine save_compressed_restart(fileObj,restartpath,append,time_level)
type(restart_file_type), intent(inout),target :: fileObj
character(len=336) :: restartpath ! The restart file path (dir/file).
! Optional arguments:
! If neither append or time_level is present:
! routine writes both meta data and field data.
! If append is present and append=.true.:
! Only field data is written.
! The field data is appended to a new time level.
! time_level must also be present and it must be >= 0.0
! The value of time_level is written as a new value of the time axis data.
! If time_level is present and time_level < 0.0:
! A new file is opened and only the meta data is written.
! If append is present and append=.false.:
! Behaves the same was as if it were not present. That is, meta data is
! written and whether or not field data is written is determined by time_level.
logical, intent(in), optional :: append
real, intent(in), optional :: time_level
integer :: unit ! The mpp unit of the open file.
type(axistype) :: x_axis, y_axis, z_axis, CC_axis, other_axis
type(axistype) :: t_axis, c_axis, h_axis ! time & sparse compressed vector axes
type(axistype) :: comp_axis
logical :: naxis_z=.false.
type(axistype), dimension(4) :: var_axes
type(var_type), pointer, save :: cur_var=>NULL()
integer :: i, j, k, l, num_var_axes, cpack, idx, mpp_action
real :: tlev
real, allocatable, dimension(:,:) :: r2d
real, allocatable, dimension(:) :: r1d
real :: r0d
integer(LONG_KIND), allocatable, dimension(:) :: check_val
character(len=256) :: checksum_char
logical :: domain_present, write_meta_data, write_field_data
logical :: c_axis_defined, h_axis_defined, CC_axis_defined
type(domain2d), pointer :: domain =>NULL()
type(ax_type), pointer :: axis =>NULL()
!-- no need to proceed if all the variables are read only.
if( all_field_read_only(fileObj) ) return
if (.not.ALLOCATED(fileObj%axes(CIDX)%idx) .and. .not.ALLOCATED(fileObj%axes(HIDX)%idx) ) then
call mpp_error(FATAL, "fms_io(save_compressed_restart): A compressed axis has "// &
"not been defined for file "//trim(fileObj%name))
else if (ALLOCATED(fileObj%axes(CIDX)%idx)) then
domain =>fileObj%axes(CIDX)%domain
else
domain =>fileObj%axes(HIDX)%domain
endif
if(present(append)) then
if(append .and. .not.present(time_level)) then
call mpp_error(FATAL, 'fms_io(save_compressed_restart): time_level must be present when append=.true.'// &
' for file '//trim(fileObj%name))
endif
endif
mpp_action = MPP_OVERWR
write_meta_data = .true.
if(present(append)) then
if(append) then
mpp_action = MPP_APPEND
write_meta_data = .false. ! Assuming meta data is already written when routine is called to append to field data.
if(time_level < 0.0) then
call mpp_error(FATAL, 'fms_io(save_compressed_restart): time_level cannot be negative when append is .true.'// &
' for file '//trim(fileObj%name))
endif
endif
endif
write_field_data = .true.
if(present(time_level)) then
write_field_data = time_level >= 0.0 ! Using negative value of time_level as a flag that there is no valid field data to write.
endif
call mpp_open(unit,trim(restartpath),action=mpp_action,form=form, &
is_root_pe=fileObj%is_root_pe, domain=domain)
if(write_meta_data) then
! User has defined axes and these are assumed to be unique
! Unfortunately it has proven difficult to write a generalized form because
! of the variations possible across all of the axes
! Currently support only 1 user defined axis of each type
! In fact, this config is specifically designed to support the land model
! sparse, compressed tile data
axis => fileobj%axes(XIDX)
if(.not. ASSOCIATED(axis)) call mpp_error(FATAL, "fms_io(save_compressed_restart): "// &
" The X axis has not been defined for "// &
" file "//trim(fileObj%name) )
call mpp_write_meta(unit,x_axis,axis%name,axis%units,axis%longname,data=axis%data,cartesian='X')
axis => fileobj%axes(YIDX)
if(.not. ASSOCIATED(axis)) call mpp_error(FATAL, "fms_io(save_compressed_restart): "// &
" The Y axis has not been defined for "// &
" file "//trim(fileObj%name) )
call mpp_write_meta(unit,y_axis,axis%name,axis%units,axis%longname,data=axis%data,cartesian='Y')
axis => fileobj%axes(ZIDX)
naxis_z = .false.
if(ASSOCIATED(axis%data))then
call mpp_write_meta(unit,z_axis,axis%name,axis%units,axis%longname, &
data=axis%data,cartesian='Z')
naxis_z = .true.
endif
axis => fileobj%axes(CCIDX)
if(ASSOCIATED(axis%data))then
call mpp_write_meta(unit,CC_axis,axis%name,axis%units,axis%longname,data=axis%data,cartesian='CC')
CC_axis_defined = .TRUE.
else
CC_axis_defined = .FALSE.
endif
! The compressed axis
axis => fileObj%axes(CIDX)
if(ALLOCATED(axis%idx)) then
call mpp_def_dim(unit,trim(axis%dimlen_name),axis%dimlen,trim(axis%dimlen_lname), (/(i,i=1,axis%dimlen)/))
call mpp_write_meta(unit,c_axis,axis%name,axis%units,axis%longname, &
data=axis%idx,compressed=axis%compressed,min=axis%imin)
c_axis_defined = .TRUE.
else
c_axis_defined = .FALSE.
endif
axis => fileObj%axes(HIDX)
if (ALLOCATED(axis%idx)) then
call mpp_def_dim(unit,trim(axis%dimlen_name),axis%dimlen,trim(axis%dimlen_lname), (/(i,i=1,axis%dimlen)/))
call mpp_write_meta(unit,h_axis,axis%name,axis%units,axis%longname, &
data=axis%idx,compressed=axis%compressed,min=axis%imin)
h_axis_defined = .TRUE.
else
h_axis_defined = .FALSE.
endif
! write out time axis
axis => fileobj%axes(TIDX)
if(ASSOCIATED(axis%data))then
call mpp_write_meta(unit,t_axis, axis%name, units=axis%units, longname=axis%longname, cartesian='T', calendar=axis%calendar)
else
call mpp_write_meta(unit,t_axis, 'Time','time level','Time',cartesian='T')
endif
! write metadata for fields
do j = 1,fileObj%nvar
cur_var => fileObj%var(j)
if(cur_var%read_only) cycle
if(cur_var%siz(4) > 1 .AND. cur_var%siz(4) .NE. fileObj%max_ntime ) call mpp_error(FATAL, &
"fms_io(save_restart): "//trim(cur_var%name)//" in file "//trim(fileObj%name)// &
" has more than one time level, but number of time level is not equal to max_ntime")
select case (trim(cur_var%compressed_axis))
case ('C')
comp_axis = c_axis
other_axis = z_axis
case ('C_CC')
comp_axis = c_axis
other_axis = CC_axis
case ('H')
comp_axis = h_axis
case default
if (ALLOCATED(fileObj%axes(CIDX)%idx)) then
comp_axis = c_axis
other_axis = z_axis
else
comp_axis = h_axis
endif
end select
if(cur_var%ndim == 0) then
num_var_axes = 1
var_axes(1) = t_axis
elseif(cur_var%ndim == 1) then
num_var_axes = 1
var_axes(1) = comp_axis
if(cur_var%siz(4) == fileObj%max_ntime) then
num_var_axes = 2
var_axes(2) = t_axis
endif
elseif(cur_var%ndim == 2) then
num_var_axes = 2
var_axes(1) = comp_axis
var_axes(2) = other_axis
if(cur_var%siz(4) == fileObj%max_ntime) then
num_var_axes = 3
var_axes(3) = t_axis
endif
elseif(cur_var%ndim == 3) then
num_var_axes = 3
var_axes(1) = comp_axis
var_axes(2) = z_axis
var_axes(3) = CC_axis
if(cur_var%siz(4) == fileObj%max_ntime) then
num_var_axes = 4
var_axes(4) = t_axis
endif
else
call mpp_error(FATAL, "fms_io(save_compressed_restart): "//trim(cur_var%name)//" in file "// &
trim(fileObj%name)//" has more than three dimensions (not including time level)")
endif
cpack = pack_size ! Default size of real
allocate(check_val(max(1,cur_var%siz(4))))
do k = 1, cur_var%siz(4)
if ( Associated(fileObj%p0dr(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p0dr(k,j)%p, (/mpp_pe()/), mask_val=cur_var%default_data)
else if ( Associated(fileObj%p1dr(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p1dr(k,j)%p(:), mask_val=cur_var%default_data)
else if ( Associated(fileObj%p2dr(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p2dr(k,j)%p(:,:), mask_val=cur_var%default_data)
else if ( Associated(fileObj%p3dr(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p3dr(k,j)%p(:,:,:))
else if ( Associated(fileObj%p0di(k,j)%p) ) then
check_val(k) = fileObj%p0di(k,j)%p
cpack = 0 ! Write data as integer*4
else if ( Associated(fileObj%p1di(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p1di(k,j)%p(:), mask_val=cur_var%default_data)
cpack = 0 ! Write data as integer*4
else if ( Associated(fileObj%p2di(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p2di(k,j)%p(:,:), mask_val=cur_var%default_data)
cpack = 0 ! Write data as integer*4
else if ( Associated(fileObj%p3di(k,j)%p) ) then
call mpp_error(FATAL, "fms_io(save_compressed_restart): integer 3D restart fields are not currently supported"// &
trim(cur_var%name)//" of file "//trim(fileObj%name) )
else
call mpp_error(FATAL, "fms_io(save_restart): There is no pointer associated with the data of field "// &
trim(cur_var%name)//" of file "//trim(fileObj%name) )
end if
enddo
! The chksum could not reproduce when running on different processor count. So commenting out now.
! Also the chksum of compressed data is not read.
if(write_field_data) then ! Write checksums only if valid field data exists
call mpp_write_meta(unit,cur_var%field, var_axes(1:num_var_axes), cur_var%name, &
cur_var%units,cur_var%longname,pack=cpack,checksum=check_val,fill=cur_var%default_data)
else
call mpp_write_meta(unit,cur_var%field, var_axes(1:num_var_axes), cur_var%name, &
cur_var%units,cur_var%longname,pack=cpack,fill=cur_var%default_data)
endif
deallocate(check_val)
enddo
! write values for ndim of spatial and compressed axes
call mpp_write(unit,x_axis)
call mpp_write(unit,y_axis)
if (c_axis_defined) call mpp_write(unit,c_axis)
if (h_axis_defined) call mpp_write(unit,h_axis)
if (CC_axis_defined) call mpp_write(unit,CC_axis)
if(naxis_z) call mpp_write(unit,z_axis)
endif ! End of section to write meta data. Write meta data only if not appending.
if(write_field_data) then
! write data of each field
do k = 1, fileObj%max_ntime
if(present(time_level)) then
tlev = time_level
else
tlev = k
endif
do j=1,fileObj%nvar
cur_var => fileObj%var(j)
if(cur_var%read_only) cycle
select case (trim(cur_var%compressed_axis))
case ('C')
idx = CIDX
case ('H')
idx = HIDX
case default
if (ALLOCATED(fileObj%axes(CIDX)%idx)) then
idx = CIDX
else
idx = HIDX
endif
end select
! If some fields only have one time level, we do not need to write the second level, just keep
! the data missing.
if(k <= cur_var%siz(4)) then
if ( Associated(fileObj%p0dr(k,j)%p) ) then
call mpp_write(unit, cur_var%field, fileObj%p0dr(k,j)%p, tlev)
elseif ( Associated(fileObj%p1dr(k,j)%p) ) then
call mpp_write_compressed(unit, cur_var%field, domain, fileObj%p1dr(k,j)%p, &
fileObj%axes(idx)%nelems(:), tstamp=tlev, default_data=cur_var%default_data)
elseif ( Associated(fileObj%p2dr(k,j)%p) ) then
call mpp_write_compressed(unit, cur_var%field, domain, fileObj%p2dr(k,j)%p, &
fileObj%axes(idx)%nelems(:), tstamp=tlev, default_data=cur_var%default_data)
elseif ( Associated(fileObj%p3dr(k,j)%p) ) then
call mpp_write_compressed(unit, cur_var%field, domain, fileObj%p3dr(k,j)%p, &
fileObj%axes(idx)%nelems(:), tstamp=tlev, default_data=cur_var%default_data)
elseif ( Associated(fileObj%p0di(k,j)%p) ) then
r0d = fileObj%p0di(k,j)%p
call mpp_write(unit, cur_var%field, r0d, tlev)
elseif ( Associated(fileObj%p1di(k,j)%p) ) then
allocate(r1d(cur_var%siz(1)) )
r1d = fileObj%p1di(k,j)%p
call mpp_write_compressed(unit, cur_var%field, domain, r1d, &
fileObj%axes(idx)%nelems(:), tstamp=tlev, default_data=cur_var%default_data)
deallocate(r1d)
elseif ( Associated(fileObj%p2di(k,j)%p) ) then
allocate(r2d(cur_var%siz(1), cur_var%siz(2)) )
r2d = fileObj%p2di(k,j)%p
call mpp_write_compressed(unit, cur_var%field, domain, r2d, &
fileObj%axes(idx)%nelems(:), tstamp=tlev, default_data=cur_var%default_data)
deallocate(r2d)
else
call mpp_error(FATAL, "fms_io(save_restart): There is no pointer associated with the data of field "// &
trim(cur_var%name)//" of file "//trim(fileObj%name) )
endif
endif
enddo ! end j loop
enddo ! end k loop
cur_var =>NULL()
endif
call mpp_close(unit)
end subroutine save_compressed_restart
!-------------------------------------------------------------------------------
!
! saves all registered variables to restart files. Those variables are set
! through register_restart_field
!
!-------------------------------------------------------------------------------
subroutine save_unlimited_axis_restart(fileObj,restartpath)
type(restart_file_type), intent(inout),target :: fileObj
character(len=336) :: restartpath ! The restart file path (dir/file).
integer :: unit ! The mpp unit of the open file.
type(axistype) :: u_axis
type(axistype), dimension(4) :: var_axes
type(var_type), pointer, save :: cur_var=>NULL()
integer :: i, j, k, l, num_var_axes, cpack, idx
real, allocatable, dimension(:) :: r1d
integer(LONG_KIND) :: check_val
character(len=256) :: checksum_char
type(domain2d), pointer :: domain =>NULL()
type(ax_type), pointer :: axis =>NULL()
if ( .NOT.fileObj%unlimited_axis ) then
call mpp_error(FATAL, "fms_io(save_unlimited_axis_restart): An unlimited axis has "// &
"not been defined for file "//trim(fileObj%name))
endif
domain =>fileObj%axes(UIDX)%domain
call mpp_open(unit,trim(restartpath),action=MPP_OVERWR,form=form, &
is_root_pe=fileObj%is_root_pe, domain=domain)
! Set unlimited axis
axis => fileobj%axes(UIDX)
call mpp_write_meta(unit,u_axis,axis%name,data=sum(axis%nelems(:)),unlimited=.true.)
call write_meta_global(unit,fileObj) ! Write any additional global metadata
call mpp_write(unit,u_axis)
! write metadata for fields
do j = 1,fileObj%nvar
cur_var => fileObj%var(j)
if(cur_var%siz(4) > 1) call mpp_error(FATAL, &
"fms_io(save_restart): "//trim(cur_var%name)//" in file "//trim(fileObj%name)// &
" has more than one time level. Only single time level is currrently supported")
if(cur_var%ndim == 1) then
num_var_axes = 1
var_axes(1) = u_axis
else
call mpp_error(FATAL, 'fms_io(save_unlimited_axis_restart): Only vectors are currently supported')
endif
cpack = pack_size ! Default size of real
if ( Associated(fileObj%p1dr(1,j)%p) ) then
check_val = mpp_chksum(fileObj%p1dr(1,j)%p(:))
else if ( Associated(fileObj%p1di(1,j)%p) ) then
! Fill values are -HUGE(i4) which don't behave as desired for checksum algorithm
check_val = mpp_chksum(INT(fileObj%p1di(1,j)%p(:),8))
cpack = 0 ! Write data as integer*4
else
call mpp_error(FATAL, "fms_io(save_unlimited_axis_restart): There is no pointer associated with the record data of field "// &
trim(cur_var%name)//" of file "//trim(fileObj%name) )
end if
call mpp_write_meta(unit,cur_var%field, var_axes(1:num_var_axes), cur_var%name, &
cur_var%units,cur_var%longname,pack=cpack,checksum=(/check_val/))
enddo ! end j loop
! write data of each field
do j=1,fileObj%nvar
cur_var => fileObj%var(j)
if ( Associated(fileObj%p1dr(1,j)%p) ) then
call mpp_write_unlimited_axis(unit,cur_var%field,domain,fileObj%p1dr(1,j)%p,fileObj%axes(UIDX)%nelems(:))
elseif ( Associated(fileObj%p1di(1,j)%p) ) then
allocate(r1d(cur_var%siz(1)) )
r1d = fileObj%p1di(1,j)%p
call mpp_write_unlimited_axis(unit,cur_var%field,domain,r1d,fileObj%axes(UIDX)%nelems(:))
deallocate(r1d)
else
call mpp_error(FATAL, "fms_io(save_restart): There is no pointer associated with the data of field "// &
trim(cur_var%name)//" of file "//trim(fileObj%name) )
endif
enddo ! end j loop
call mpp_close(unit)
cur_var =>NULL()
end subroutine save_unlimited_axis_restart
!-------------------------------------------------------------------------------
!
! saves all registered variables to restart files. Those variables are set
! through register_restart_field
!
!-------------------------------------------------------------------------------
subroutine save_default_restart(fileObj,restartpath)
type(restart_file_type), intent(inout) :: fileObj
character(len=336) :: restartpath ! The restart file path (dir/file).
character(len=8) :: suffix ! A suffix (like _2) that is appended to the name of files after the first.
integer :: var_sz, size_in_file ! The size in bytes of each variable and of the variables already in a file.
integer :: unit ! The mpp unit of the open file.
real, dimension(max_axis_size) :: axisdata
integer, dimension(max_axes) :: id_x_axes, siz_x_axes
integer, dimension(max_axes) :: id_y_axes, siz_y_axes
integer, dimension(max_axes) :: id_z_axes, siz_z_axes
integer, dimension(max_axes) :: id_a_axes, siz_a_axes
integer, dimension(max_axes) :: x_axes_indx, y_axes_indx, z_axes_indx, a_axes_indx
type(axistype), dimension(max_axes) :: x_axes, y_axes, z_axes, a_axes
type(axistype) :: t_axes
integer :: num_var_axes
type(axistype), dimension(5) :: var_axes
type(var_type), pointer, save :: cur_var=>NULL()
integer :: num_x_axes, num_y_axes, num_z_axes, num_a_axes
integer :: naxes_x, naxes_y, naxes_z, naxes_a
integer :: i, j, k, l, siz, ind_dom
logical :: domain_present
real :: tlev
real(DOUBLE_KIND) :: tlev_r8
character(len=10) :: axisname
integer :: meta_size
type(domain2d) :: domain
real, allocatable, dimension(:,:,:) :: r3d
real, allocatable, dimension(:,:) :: r2d
real, allocatable, dimension(:) :: r1d
real :: r0d
integer(LONG_KIND), allocatable, dimension(:) :: check_val
character(len=256) :: checksum_char
integer :: isc, iec, jsc, jec
integer :: isg, ieg, jsg, jeg
integer :: ishift, jshift, iadd, jadd, cpack_size
logical :: write_on_this_pe
type(domain2d), pointer :: io_domain =>NULL()
if (.not.associated(fileObj%var)) call mpp_error(FATAL, "fms_io(save_restart): " // &
"restart_file_type data must be initialized by calling register_restart_field before using it")
!-- no need to proceed if all the variables are read only.
if( all_field_read_only(fileObj) ) return
do i=1,max_axis_size
axisdata(i) = i
enddo
!--- check if any field in this file present domain.
domain_present = .false.
do j = 1, fileObj%nvar
if (fileObj%var(j)%domain_present) then
domain_present = .true.
ind_dom = j
exit
end if
end do
num_x_axes = unique_axes(fileObj, 1, id_x_axes, siz_x_axes, domain_x)
num_y_axes = unique_axes(fileObj, 2, id_y_axes, siz_y_axes, domain_y)
num_z_axes = unique_axes(fileObj, 3, id_z_axes, siz_z_axes )
num_a_axes = unique_axes(fileObj, 4, id_a_axes, siz_a_axes )
write_on_this_pe = .false.
if(domain_present) then
io_domain => mpp_get_io_domain(array_domain(fileObj%var(ind_dom)%domain_idx))
if(associated(io_domain)) then
if(mpp_domain_is_tile_root_pe(io_domain)) write_on_this_pe = .true.
endif
endif
!--- always write out from root pe
if( fileObj%is_root_pe ) write_on_this_pe = .true.
if( domain_present ) then
call mpp_open(unit,trim(restartpath),action=MPP_OVERWR,form=form,&
is_root_pe=fileObj%is_root_pe, domain=array_domain(fileObj%var(ind_dom)%domain_idx) )
else ! global data
call mpp_open(unit,trim(restartpath),action=MPP_OVERWR,form=form,threading=MPP_SINGLE,&
fileset=MPP_SINGLE, is_root_pe=fileObj%is_root_pe)
end if
naxes_x = 0
x_axes_indx = 0
y_axes_indx = 0
z_axes_indx = 0
a_axes_indx = 0
! write_out x_axes
do j = 1, num_x_axes
! make sure this axis is used by some variable
do l=1,fileObj%nvar
if(fileObj%var(l)%read_only) cycle
if( fileObj%var(l)%id_axes(1) == j ) exit
end do
if( l > fileObj%nvar ) cycle
naxes_x = naxes_x + 1
x_axes_indx(naxes_x) = j
if (naxes_x < 10) then
write(axisname,'(a,i1)') 'xaxis_',naxes_x
else
write(axisname,'(a,i2)') 'xaxis_',naxes_x
endif
if(id_x_axes(j) > 0) then
call mpp_write_meta(unit,x_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_x_axes(j)),domain=domain_x(id_x_axes(j)),cartesian='X')
else
call mpp_write_meta(unit,x_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_x_axes(j)),cartesian='X')
endif
end do
! write out y_axes
naxes_y = 0
do j = 1, num_y_axes
! make sure this axis is used by some variable
do l=1,fileObj%nvar
if(fileObj%var(l)%read_only) cycle
if( fileObj%var(l)%id_axes(2) == j ) exit
end do
if( l > fileObj%nvar ) cycle
naxes_y = naxes_y + 1
y_axes_indx(naxes_y) = j
if (naxes_y < 10) then
write(axisname,'(a,i1)') 'yaxis_',naxes_y
else
write(axisname,'(a,i2)') 'yaxis_',naxes_y
endif
if(id_y_axes(j) > 0) then
call mpp_write_meta(unit,y_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_y_axes(j)),domain=domain_y(id_y_axes(j)),cartesian='Y')
else
call mpp_write_meta(unit,y_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_y_axes(j)),cartesian='Y')
endif
end do
! write out z_axes
naxes_z = 0
do j = 1, num_z_axes
! make sure this axis is used by some variable
do l=1,fileObj%nvar
if(fileObj%var(l)%read_only) cycle
if( fileObj%var(l)%id_axes(3) == j ) exit
end do
if( l > fileObj%nvar ) cycle
naxes_z = naxes_z + 1
z_axes_indx(naxes_z) = j
if (naxes_z < 10) then
write(axisname,'(a,i1)') 'zaxis_',naxes_z
else
write(axisname,'(a,i2)') 'zaxis_',naxes_z
endif
call mpp_write_meta(unit,z_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_z_axes(j)),cartesian='Z')
end do
! write out a_axes
naxes_a = 0
do j = 1, num_a_axes
! make sure this axis is used by some variable
do l=1,fileObj%nvar
if(fileObj%var(l)%read_only) cycle
if( fileObj%var(l)%id_axes(4) == j ) exit
end do
if( l > fileObj%nvar ) cycle
naxes_a = naxes_a + 1
a_axes_indx(naxes_a) = j
if (naxes_a < 10) then
write(axisname,'(a,i1)') 'aaxis_',naxes_a
else
write(axisname,'(a,i2)') 'aaxis_',naxes_a
endif
call mpp_write_meta(unit,a_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_a_axes(j)),cartesian='N')
end do
! write out time axis
call mpp_write_meta(unit,t_axes,&
'Time','time level','Time',cartesian='T')
! write metadata for fields
do j = 1,fileObj%nvar
cur_var => fileObj%var(j)
if(cur_var%read_only) cycle
if(cur_var%siz(4) > 1 .AND. cur_var%siz(4) .NE. fileObj%max_ntime ) call mpp_error(FATAL, &
"fms_io(save_restart): "//trim(cur_var%name)//" in file "//trim(fileObj%name)// &
" has more than one time level, but number of time level is not equal to max_ntime")
if(cur_var%ndim == 0) then
num_var_axes = 1
var_axes(1) = t_axes
else if(cur_var%ndim == 1) then
num_var_axes = 1
var_axes(1) = x_axes(cur_var%id_axes(1))
if(cur_var%siz(4) == fileObj%max_ntime) then
num_var_axes = 2
var_axes(2) = t_axes
end if
else if(cur_var%ndim == 2) then
num_var_axes = 2
var_axes(1) = x_axes(cur_var%id_axes(1))
var_axes(2) = y_axes(cur_var%id_axes(2))
if(cur_var%siz(4) == fileObj%max_ntime) then
num_var_axes = 3
var_axes(3) = t_axes
end if
else if(cur_var%ndim == 3) then
num_var_axes = 3
var_axes(1) = x_axes(cur_var%id_axes(1))
var_axes(2) = y_axes(cur_var%id_axes(2))
var_axes(3) = z_axes(cur_var%id_axes(3))
if(cur_var%siz(4) == fileObj%max_ntime) then
num_var_axes = 4
var_axes(4) = t_axes
end if
else if(cur_var%ndim == 4) then
num_var_axes = 4
var_axes(1) = x_axes(cur_var%id_axes(1))
var_axes(2) = y_axes(cur_var%id_axes(2))
var_axes(3) = z_axes(cur_var%id_axes(3))
var_axes(4) = a_axes(cur_var%id_axes(4))
if(cur_var%siz(4) == fileObj%max_ntime) then
num_var_axes = 5
var_axes(5) = t_axes
end if
end if
if ( cur_var%domain_idx > 0) then
call mpp_get_compute_domain(array_domain(cur_var%domain_idx), isc, iec, jsc, jec)
call mpp_get_global_domain(array_domain(cur_var%domain_idx), isg, ieg, jsg, jeg)
call mpp_get_domain_shift(array_domain(cur_var%domain_idx), ishift, jshift, cur_var%position)
else if (ASSOCIATED(Current_domain)) then
call mpp_get_compute_domain(Current_domain, isc, iec, jsc, jec)
call mpp_get_global_domain(Current_domain, isg, ieg, jsg, jeg)
call mpp_get_domain_shift(Current_domain, ishift, jshift, cur_var%position)
else
iec = cur_var%ie
isc = cur_var%is
ieg = cur_var%ie
jec = cur_var%je
jsc = cur_var%js
jeg = cur_var%je
ishift = 0
jshift = 0
endif
! call return_domain(domain)
iadd = iec-isc ! Size of the i-dimension on this processor (-1 as it is an increment)
jadd = jec-jsc ! Size of the j-dimension on this processor
if(iec == ieg) iadd = iadd + ishift
if(jec == jeg) jadd = jadd + jshift
allocate(check_val(max(1,cur_var%siz(4))))
cpack_size = pack_size
do k = 1, cur_var%siz(4)
if ( Associated(fileObj%p0dr(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p0dr(k,j)%p, (/mpp_pe()/) )
else if ( Associated(fileObj%p1dr(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p1dr(k,j)%p, (/mpp_pe()/) )
else if ( Associated(fileObj%p2dr(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p2dr(k,j)%p(cur_var%is:cur_var%is+iadd, cur_var%js:cur_var%js+jadd) )
else if ( Associated(fileObj%p3dr(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p3dr(k,j)%p(cur_var%is:cur_var%is+iadd, cur_var%js:cur_var%js+jadd, :) )
else if ( Associated(fileObj%p2dr8(k,j)%p) ) then
cpack_size = 1
check_val(k) = mpp_chksum(fileObj%p2dr8(k,j)%p(cur_var%is:cur_var%is+iadd, cur_var%js:cur_var%js+jadd) )
else if ( Associated(fileObj%p3dr8(k,j)%p) ) then
cpack_size = 1
check_val(k) = mpp_chksum(fileObj%p3dr8(k,j)%p(cur_var%is:cur_var%is+iadd, cur_var%js:cur_var%js+jadd, :) )
else if ( Associated(fileObj%p4dr(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p4dr(k,j)%p(cur_var%is:cur_var%is+iadd, cur_var%js:cur_var%js+jadd, :, :) )
else if ( Associated(fileObj%p0di(k,j)%p) ) then
check_val(k) = fileObj%p0di(k,j)%p
else if ( Associated(fileObj%p1di(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p1di(k,j)%p, (/mpp_pe()/) )
else if ( Associated(fileObj%p2di(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p2di(k,j)%p(cur_var%is:cur_var%is+iadd, cur_var%js:cur_var%js+jadd) )
else if ( Associated(fileObj%p3di(k,j)%p) ) then
check_val(k) = mpp_chksum(fileObj%p3di(k,j)%p(cur_var%is:cur_var%is+iadd, cur_var%js:cur_var%js+jadd, :))
else
call mpp_error(FATAL, "fms_io(save_restart): There is no pointer associated with the data of field "// &
trim(cur_var%name)//" of file "//trim(fileObj%name) )
end if
enddo
call mpp_write_meta(unit,cur_var%field, var_axes(1:num_var_axes), cur_var%name, &
cur_var%units,cur_var%longname,pack=cpack_size,checksum=check_val)
deallocate(check_val)
enddo
! write values for ndim of spatial axes
do j = 1, naxes_x
call mpp_write(unit,x_axes(x_axes_indx(j)))
enddo
do j = 1, naxes_y
call mpp_write(unit,y_axes(y_axes_indx(j)))
enddo
do j = 1, naxes_z
call mpp_write(unit,z_axes(z_axes_indx(j)))
enddo
do j = 1, naxes_a
call mpp_write(unit,a_axes(a_axes_indx(j)))
enddo
! write data of each field
do k = 1, fileObj%max_ntime
do j=1,fileObj%nvar
cur_var => fileObj%var(j)
if(cur_var%read_only) cycle
tlev =k
tlev_r8=k
! If some fields only have one time level, we do not need to write the second level, just keep
! the data missing.
if(k <= cur_var%siz(4)) then
if(cur_var%domain_present) then ! one 2-D or 3-D case possible present domain
if( Associated(fileObj%p2dr(k,j)%p) ) then
call mpp_write(unit, cur_var%field, array_domain(cur_var%domain_idx), fileObj%p2dr(k,j)%p, tlev, &
default_data=cur_var%default_data)
else if( Associated(fileObj%p3dr(k,j)%p) ) then
call mpp_write(unit, cur_var%field, array_domain(cur_var%domain_idx), fileObj%p3dr(k,j)%p, tlev, &
default_data=cur_var%default_data)
else if( Associated(fileObj%p2dr8(k,j)%p) ) then
call mpp_write(unit, cur_var%field, array_domain(cur_var%domain_idx), fileObj%p2dr8(k,j)%p, tlev_r8, &
default_data=real(cur_var%default_data,kind=DOUBLE_KIND))
else if( Associated(fileObj%p3dr8(k,j)%p) ) then
call mpp_write(unit, cur_var%field, array_domain(cur_var%domain_idx), fileObj%p3dr8(k,j)%p, tlev_r8, &
default_data=real(cur_var%default_data,kind=DOUBLE_KIND))
else if( Associated(fileObj%p4dr(k,j)%p) ) then
call mpp_write(unit, cur_var%field, array_domain(cur_var%domain_idx), fileObj%p4dr(k,j)%p, tlev, &
default_data=cur_var%default_data)
else if( Associated(fileObj%p2di(k,j)%p) ) then
allocate(r2d(cur_var%siz(1), cur_var%siz(2)) )
r2d = fileObj%p2di(k,j)%p
call mpp_write(unit, cur_var%field, array_domain(cur_var%domain_idx), r2d, tlev, &
default_data=cur_var%default_data)
deallocate(r2d)
else if( Associated(fileObj%p3di(k,j)%p) ) then
allocate(r3d(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3)) )
r3d = fileObj%p3di(k,j)%p
call mpp_write(unit, cur_var%field, array_domain(cur_var%domain_idx), r3d, tlev, &
default_data=cur_var%default_data)
deallocate(r3d)
else
call mpp_error(FATAL, "fms_io(save_restart): domain is present, "// &
"field "//trim(cur_var%name)//" of file "//trim(fileObj%name)// &
", but none of p2dr, p3dr, p2di and p3di is associated")
end if
else if (write_on_this_pe) then
if ( Associated(fileObj%p0dr(k,j)%p) ) then
call mpp_write(unit, cur_var%field, fileObj%p0dr(k,j)%p, tlev)
else if ( Associated(fileObj%p1dr(k,j)%p) ) then
call mpp_write(unit, cur_var%field, fileObj%p1dr(k,j)%p, tlev)
else if ( Associated(fileObj%p2dr(k,j)%p) ) then
call mpp_write(unit, cur_var%field, fileObj%p2dr(k,j)%p, tlev)
else if ( Associated(fileObj%p3dr(k,j)%p) ) then
call mpp_write(unit, cur_var%field, fileObj%p3dr(k,j)%p, tlev)
! else if ( Associated(fileObj%p2dr8(k,j)%p) ) then
! call mpp_write(unit, cur_var%field, fileObj%p2dr8(k,j)%p, tlev_r8)
! else if ( Associated(fileObj%p3dr8(k,j)%p) ) then
! call mpp_write(unit, cur_var%field, fileObj%p3dr8(k,j)%p, tlev_r8)
else if ( Associated(fileObj%p4dr(k,j)%p) ) then
call mpp_write(unit, cur_var%field, fileObj%p4dr(k,j)%p, tlev)
else if ( Associated(fileObj%p0di(k,j)%p) ) then
r0d = fileObj%p0di(k,j)%p
call mpp_write(unit, cur_var%field, r0d, tlev)
else if ( Associated(fileObj%p1di(k,j)%p) ) then
allocate(r1d(cur_var%siz(1)) )
r1d = fileObj%p1di(k,j)%p
call mpp_write(unit, cur_var%field, r1d, tlev)
deallocate(r1d)
else if ( Associated(fileObj%p2di(k,j)%p) ) then
allocate(r2d(cur_var%siz(1), cur_var%siz(2)) )
r2d = fileObj%p2di(k,j)%p
call mpp_write(unit, cur_var%field, r2d, tlev)
deallocate(r2d)
else if ( Associated(fileObj%p3di(k,j)%p) ) then
allocate(r3d(cur_var%siz(1), cur_var%siz(2), cur_var%siz(3)) )
r3d = fileObj%p3di(k,j)%p
call mpp_write(unit, cur_var%field, r3d, tlev)
deallocate(r3d)
else
call mpp_error(FATAL, "fms_io(save_restart): There is no pointer associated with the data of field "// &
trim(cur_var%name)//" of file "//trim(fileObj%name) )
end if
end if
end if
enddo ! end j loop
enddo ! end k loop
call mpp_close(unit)
cur_var =>NULL()
end subroutine save_default_restart
!-------------------------------------------------------------------------------
!
! saves all registered border/halo variables to restart files. Those variables
! are set through register_restart_field (region option)
!
!-------------------------------------------------------------------------------
subroutine save_restart_border (fileObj, time_stamp, directory)
type(restart_file_type), intent(inout) :: fileObj
character(len=*), intent(in), optional :: directory
character(len=*), intent(in), optional :: time_stamp
character(len=256) :: dir
character(len=256) :: restartpath ! The restart file path (dir/file).
character(len=80) :: restartname ! The restart file name (no dir).
!rab integer :: start_var, next_var ! The starting variables of the current and next files.
integer :: unit ! The mpp unit of the open file.
real, dimension(max_axis_size) :: axisdata
integer, dimension(max_axes) :: id_x_axes, siz_x_axes
integer, dimension(max_axes) :: id_y_axes, siz_y_axes
integer, dimension(max_axes) :: id_z_axes, siz_z_axes
integer, dimension(max_axes) :: x_axes_indx, y_axes_indx, z_axes_indx
type(axistype), dimension(max_axes) :: x_axes, y_axes, z_axes
type(axistype) :: t_axes
integer :: num_var_axes
type(axistype), dimension(4) :: var_axes
type(var_type), pointer, save :: cur_var=>NULL()
integer :: num_x_axes, num_y_axes, num_z_axes
integer :: naxes_x, naxes_y, naxes_z
integer :: i, j, k, l
integer :: isc, iec, jsc, jec
integer :: is, ie, js, je
integer :: i_add, i1, i2
integer :: j_add, j1, j2
integer :: i_glob, j_glob, k_glob
real :: tlev
character(len=10) :: axisname
real, allocatable, dimension(:,:) :: r2d
real, allocatable, dimension(:,:,:) :: r3d
integer(LONG_KIND), allocatable, dimension(:) :: check_val
!-- no need to proceed if all the variables are read only.
if( all_field_read_only(fileObj) ) return
do i=1,max_axis_size
axisdata(i) = i
enddo
dir = "RESTART"
if(present(directory)) dir = directory
restartname = fileObj%name
if (time_stamp_restart) then
if (PRESENT(time_stamp)) then
restartname = trim(time_stamp)//"."//trim(restartname)
endif
end if
if (len_trim(dir) > 0) then
restartpath = trim(dir)//"/"// trim(restartname)
else
restartpath = trim(restartname)
end if
num_x_axes = unique_axes(fileObj, 1, id_x_axes, siz_x_axes)
num_y_axes = unique_axes(fileObj, 2, id_y_axes, siz_y_axes)
num_z_axes = unique_axes(fileObj, 3, id_z_axes, siz_z_axes)
call mpp_open(unit,trim(restartpath),action=MPP_OVERWR,form=MPP_NETCDF,threading=MPP_SINGLE,&
fileset=MPP_SINGLE, is_root_pe=fileObj%is_root_pe)
! write out axes
naxes_x = 0
x_axes_indx = 0
y_axes_indx = 0
z_axes_indx = 0
! write out x_axes metadata
do j = 1, num_x_axes
! make sure this axis is used by some variable
do l=1, fileObj%nvar
if(fileObj%var(l)%read_only) cycle
if (fileObj%var(l)%id_axes(1) == j) exit
end do
if( l > fileObj%nvar ) cycle
naxes_x = naxes_x + 1
x_axes_indx(naxes_x) = j
if (naxes_x < 10) then
write(axisname,'(a,i1)') 'xaxis_',naxes_x
else
write(axisname,'(a,i2)') 'xaxis_',naxes_x
endif
call mpp_write_meta(unit,x_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_x_axes(j)),cartesian='X')
end do
! write out y_axes metadata
naxes_y = 0
do j = 1, num_y_axes
! make sure this axis is used by some variable
do l=1, fileObj%nvar
if(fileObj%var(l)%read_only) cycle
if (fileObj%var(l)%id_axes(2) == j) exit
end do
if( l > fileObj%nvar ) cycle
naxes_y = naxes_y + 1
y_axes_indx(naxes_y) = j
if (naxes_y < 10) then
write(axisname,'(a,i1)') 'yaxis_',naxes_y
else
write(axisname,'(a,i2)') 'yaxis_',naxes_y
endif
call mpp_write_meta(unit,y_axes(j),axisname,'none',axisname, &
data=axisdata(1:siz_y_axes(j)),cartesian='Y')
end do
! write out z_axes metadata
naxes_z = 0
do j = 1, num_z_axes
! make sure this axis is used by some variable
do l=1, fileObj%nvar
if(fileObj%var(l)%read_only) cycle
if (fileObj%var(l)%id_axes(3) == j) exit
end do
if( l > fileObj%nvar ) cycle