29 use fms_netcdf_domain_io_mod
 
   30 use fms_netcdf_unstructured_domain_io_mod
 
   32 use, 
intrinsic :: iso_fortran_env, only: error_unit
 
   37 integer, 
private :: fms2_ncchksz = -1
 
   53 integer, 
intent(in) :: chksz
 
   62   character(len=*), 
intent(in) :: path
 
   63   character(len=*), 
intent(out) :: new_path
 
   64   character(len=*), 
intent(in), 
optional :: directory
 
   65   character(len=*), 
intent(in), 
optional :: timestamp
 
   66   character(len=*), 
intent(in), 
optional :: new_name
 
   68   character(len=FMS_PATH_LEN) :: dir
 
   69   character(len=FMS_FILE_LEN) :: tstamp
 
   70   character(len=FMS_PATH_LEN) :: nname
 
   73   if (
present(directory)) 
then 
   74     call string_copy(dir, trim(directory)//
"/")
 
   77   if (
present(timestamp)) 
then 
   78     call string_copy(tstamp, trim(timestamp)//
".")
 
   80   call string_copy(nname, trim(path))
 
   81   if (
present(new_name)) 
then 
   82     call string_copy(nname, trim(new_name))
 
   84   call string_copy(new_path, trim(dir)//trim(tstamp)//trim(nname))
 
   92   character(len=*), 
intent(out) :: filename
 
   98     call random_number(numr)
 
   99     numi = transfer(numr, numi)
 
  100     numi = iand(numi, z
'FFFFFF')
 
  101     write(filename, 
'(a,z6.6)') 
"tmp", numi
 
  117   integer, 
dimension(:), 
intent(in), 
optional :: pelist
 
  122   character(len=*), 
intent(in), 
optional :: path
 
  128   if (
present(path)) 
then 
  129     call string_copy(fileobj%path, path)
 
  133   fileobj%nc_format = 
"classic" 
  134   fileobj%is_readonly = .false.
 
  135   if (
present(pelist)) 
then 
  136     allocate(fileobj%pelist(
size(pelist)))
 
  137     fileobj%pelist(:) = pelist(:)
 
  139     allocate(fileobj%pelist(1))
 
  140     fileobj%pelist(1) = 
mpp_pe()
 
  142   fileobj%io_root = fileobj%pelist(1)
 
  143   fileobj%is_root = 
mpp_pe() .eq. fileobj%io_root
 
  144   fileobj%is_restart = .true.
 
  145   fileobj%is_diskless = .true.
 
  146   cmode = ior(nf90_noclobber, nf90_classic_model)
 
  147   cmode = ior(cmode, nf90_diskless)
 
  148   if (fms2_ncchksz == -1) 
call error(
"create_diskless_netcdf_file :: fms2_ncchksz not set. Call fms2_io init first")
 
  149   err = nf90_create(trim(fileobj%path), cmode, fileobj%ncid, chunksize=fms2_ncchksz)
 
  150   success = err .eq. nf90_noerr
 
  151   if (.not. success) 
then 
  152     deallocate(fileobj%pelist)
 
  155   allocate(fileobj%restart_vars(max_num_restart_vars))
 
  156   fileobj%num_restart_vars = 0
 
  157   allocate(fileobj%compressed_dims(max_num_compressed_dims))
 
  158   fileobj%num_compressed_dims = 0
 
  174   character(len=nf90_max_name) :: n
 
  175   character(len=nf90_max_name) :: varname
 
  176   character(len=nf90_max_name), 
dimension(nf90_max_dims) :: dimnames
 
  177   integer, 
dimension(nf90_max_dims) :: dimlens
 
  179   integer, 
dimension(nf90_max_var_dims) :: dimids
 
  180   integer, 
dimension(nf90_max_var_dims) :: d
 
  181   integer :: ulim_dimid
 
  186   integer(kind=i4_kind), 
dimension(:), 
allocatable :: buf_int
 
  187   real(kind=r4_kind), 
dimension(:), 
allocatable :: buf_float
 
  188   real(kind=r8_kind), 
dimension(:), 
allocatable :: buf_double
 
  189   character(len=200) :: append_error_msg
 
  191   append_error_msg = 
"copy_metadata: original file:"//trim(fileobj%path)//
" new file:"//trim(new_fileobj%path)
 
  192   if (fileobj%is_root .and. .not. new_fileobj%is_readonly) 
then 
  196     err = nf90_inquire(fileobj%ncid, nattributes=natt)
 
  199       err = nf90_inq_attname(fileobj%ncid, nf90_global, i, n)
 
  201       err = nf90_copy_att(fileobj%ncid, nf90_global, n, new_fileobj%ncid, nf90_global)
 
  206     err = nf90_inquire(fileobj%ncid, ndimensions=ndim)
 
  208     err = nf90_inquire(fileobj%ncid, unlimiteddimid=ulim_dimid)
 
  211       err = nf90_inquire_dimension(fileobj%ncid, i, dimnames(i), dimlens(i))
 
  213       if (i .eq. ulim_dimid) 
then 
  214         err = nf90_def_dim(new_fileobj%ncid, dimnames(i), nf90_unlimited, dimids(i))
 
  215         ulim_dimid = dimids(i)
 
  217         err = nf90_def_dim(new_fileobj%ncid, dimnames(i), dimlens(i), dimids(i))
 
  223     err = nf90_inquire(fileobj%ncid, nvariables=nvar)
 
  226       err = nf90_inquire_variable(fileobj%ncid, i, varname, xtype, varndim, d, natt)
 
  231         err = nf90_inquire_dimension(fileobj%ncid, d(j), n)
 
  242       err = nf90_def_var(new_fileobj%ncid, varname, xtype, d(1:varndim), varid)
 
  246       if (varndim .eq. 1 .and. d(1) .ne. ulim_dimid) 
then 
  251             if (xtype .eq. nf90_int) 
then 
  252               allocate(buf_int(dimlens(k)))
 
  253               err = nf90_get_var(fileobj%ncid, i, buf_int)
 
  255               err = nf90_put_var(new_fileobj%ncid, varid, buf_int)
 
  257             elseif (xtype .eq. nf90_float) 
then 
  258               allocate(buf_float(dimlens(k)))
 
  259               err = nf90_get_var(fileobj%ncid, i, buf_float)
 
  261               err = nf90_put_var(new_fileobj%ncid, varid, buf_float)
 
  262               deallocate(buf_float)
 
  263             elseif (xtype .eq. nf90_double) 
then 
  264               allocate(buf_double(dimlens(k)))
 
  265               err = nf90_get_var(fileobj%ncid, i, buf_double)
 
  267               err = nf90_put_var(new_fileobj%ncid, varid, buf_double)
 
  268               deallocate(buf_double)
 
  270               call error(append_error_msg//
" "//trim(varname)//
" has an unsupported type, "&
 
  271                         //
"only nf90_int, nf90_float, and nf90_double are currently supported")
 
  284         err = nf90_inq_attname(fileobj%ncid, i, j, n)
 
  286         err = nf90_copy_att(fileobj%ncid, i, n, new_fileobj%ncid, varid)
 
  292   if (new_fileobj%is_restart) 
then 
  294     do i = 1, fileobj%num_restart_vars
 
  295       new_fileobj%restart_vars(i)%varname = fileobj%restart_vars(i)%varname
 
  296       if (
associated(fileobj%restart_vars(i)%data0d)) 
then 
  297         new_fileobj%restart_vars(i)%data0d => fileobj%restart_vars(i)%data0d
 
  298       elseif (
associated(fileobj%restart_vars(i)%data1d)) 
then 
  299         new_fileobj%restart_vars(i)%data1d => fileobj%restart_vars(i)%data1d
 
  300       elseif (
associated(fileobj%restart_vars(i)%data2d)) 
then 
  301         new_fileobj%restart_vars(i)%data2d => fileobj%restart_vars(i)%data2d
 
  302       elseif (
associated(fileobj%restart_vars(i)%data3d)) 
then 
  303         new_fileobj%restart_vars(i)%data3d => fileobj%restart_vars(i)%data3d
 
  304       elseif (
associated(fileobj%restart_vars(i)%data4d)) 
then 
  305         new_fileobj%restart_vars(i)%data4d => fileobj%restart_vars(i)%data4d
 
  307         call error(
"this branch should not be reached.")
 
  310     new_fileobj%num_restart_vars = fileobj%num_restart_vars
 
  314   do i = 1, fileobj%num_compressed_dims
 
  315     new_fileobj%compressed_dims(i)%dimname = fileobj%compressed_dims(i)%dimname
 
  316     k = 
size(fileobj%compressed_dims(i)%npes_corner)
 
  317     allocate(new_fileobj%compressed_dims(i)%npes_corner(k))
 
  318     allocate(new_fileobj%compressed_dims(i)%npes_nelems(k))
 
  320       new_fileobj%compressed_dims(i)%npes_corner(j) = fileobj%compressed_dims(i)%npes_corner(j)
 
  321       new_fileobj%compressed_dims(i)%npes_nelems(j) = fileobj%compressed_dims(i)%npes_nelems(j)
 
  323     new_fileobj%compressed_dims(i)%nelems = fileobj%compressed_dims(i)%nelems
 
  325   new_fileobj%num_compressed_dims = fileobj%num_compressed_dims
 
  334   character(len=*), 
intent(in) :: path
 
  335   character(len=*), 
intent(in) :: mode
 
  339   character(len=*), 
intent(in), 
optional :: nc_format
 
  350                              fileobj%pelist, fileobj%is_restart)
 
  351   if (.not. success) 
then 
  352     call error(
"error opening file "//trim(path)//
".")
 
  365   integer, 
dimension(:), 
intent(in), 
optional :: pelist
 
  370   character(len=*), 
intent(in), 
optional :: path
 
  382   integer, 
intent(in), 
optional :: unlim_dim_level
 
  384   character(len=*), 
intent(in), 
optional :: directory
 
  385   character(len=*), 
intent(in), 
optional :: timestamp
 
  386   character(len=*), 
intent(in), 
optional :: filename
 
  387   character(len=*), 
intent(in), 
optional :: nc_format
 
  394   character(len=FMS_PATH_LEN) :: new_name
 
  397   logical :: close_new_file
 
  399   call get_new_filename(fileobj%path, new_name, directory, timestamp, filename)
 
  402     close_new_file = .false.
 
  404     call new_netcdf_file(fileobj, new_name, 
"write", new_fileobj, nc_format)
 
  406     close_new_file = .true.
 
  409   if (close_new_file) 
then 
  421   integer, 
intent(in), 
optional :: unlim_dim_level
 
  423   character(len=*), 
intent(in), 
optional :: directory
 
  424   character(len=*), 
intent(in), 
optional :: timestamp
 
  425   character(len=*), 
intent(in), 
optional :: filename
 
  427   character(len=FMS_PATH_LEN) :: new_name
 
  430   logical :: close_new_file
 
  432   call get_new_filename(fileobj%path, new_name, directory, timestamp, filename)
 
  435     close_new_file = .false.
 
  439     close_new_file = .true.
 
  442   if (close_new_file) 
then 
  455   type(
domain2d), 
intent(in) :: domain
 
  456   character(len=*), 
intent(in), 
optional :: path
 
  459   type(
domain2d), 
pointer :: io_domain
 
  460   integer :: pelist_size
 
  461   integer, 
dimension(:), 
allocatable :: pelist
 
  464   if (.not. 
associated(io_domain)) 
then 
  465     call error(
"The domain associated with the file: "//trim(fileobj%path)//
" does not have an io_domain.")
 
  468   allocate(pelist(pelist_size))
 
  472   fileobj%domain = domain
 
  473   allocate(fileobj%xdims(max_num_domain_decomposed_dims))
 
  475   allocate(fileobj%ydims(max_num_domain_decomposed_dims))
 
  477   call string_copy(fileobj%non_mangled_path, fileobj%path)
 
  486   character(len=*), 
intent(in) :: path
 
  487   character(len=*), 
intent(in) :: mode
 
  490   character(len=*), 
intent(in), 
optional :: nc_format
 
  500   success = 
open_domain_file(new_fileobj, path, mode, fileobj%domain, nc_format, &
 
  502   if (.not. success) 
then 
  503     call error(
"error opening file "//trim(path)//
".")
 
  507     call string_copy(new_fileobj%xdims(i)%varname, fileobj%xdims(i)%varname)
 
  508     new_fileobj%xdims(i)%pos = fileobj%xdims(i)%pos
 
  510   new_fileobj%nx = fileobj%nx
 
  512     call string_copy(new_fileobj%ydims(i)%varname, fileobj%ydims(i)%varname)
 
  513     new_fileobj%ydims(i)%pos = fileobj%ydims(i)%pos
 
  515   new_fileobj%ny = fileobj%ny
 
  525   integer, 
intent(in), 
optional :: unlim_dim_level
 
  526   character(len=*), 
intent(in), 
optional :: directory
 
  527   character(len=*), 
intent(in), 
optional :: timestamp
 
  528   character(len=*), 
intent(in), 
optional :: filename
 
  529   character(len=*), 
intent(in), 
optional :: nc_format
 
  536   character(len=FMS_PATH_LEN) :: new_name
 
  539   logical :: close_new_file
 
  541   call get_new_filename(fileobj%non_mangled_path, new_name, directory, timestamp, filename)
 
  544     close_new_file = .false.
 
  546     call new_domain_file(fileobj, new_name, 
"write", new_fileobj, nc_format)
 
  548     close_new_file = .true.
 
  551   if (close_new_file) 
then 
  560                                      filename, ignore_checksum)
 
  563   integer, 
intent(in), 
optional :: unlim_dim_level
 
  564   character(len=*), 
intent(in), 
optional :: directory
 
  565   character(len=*), 
intent(in), 
optional :: timestamp
 
  566   character(len=*), 
intent(in), 
optional :: filename
 
  567   logical,          
intent(in), 
optional :: ignore_checksum
 
  569   character(len=FMS_PATH_LEN) :: new_name
 
  572   logical :: close_new_file
 
  574   call get_new_filename(fileobj%non_mangled_path, new_name, directory, timestamp, filename)
 
  577     close_new_file = .false.
 
  581     close_new_file = .true.
 
  584   if (close_new_file) 
then 
  597   type(
domainug), 
intent(in) :: domain
 
  598   character(len=*), 
intent(in), 
optional :: path
 
  601   type(
domainug), 
pointer :: io_domain
 
  602   integer :: pelist_size
 
  603   integer, 
dimension(:), 
allocatable :: pelist
 
  605   io_domain => mpp_get_ug_io_domain(domain)
 
  606   if (.not. 
associated(io_domain)) 
then 
  607     call error(
"The domain associated with the file: "//trim(fileobj%path)//
" does have an io_domain.")
 
  609   pelist_size = mpp_get_ug_domain_npes(io_domain)
 
  610   allocate(pelist(pelist_size))
 
  611   call mpp_get_ug_domain_pelist(io_domain, pelist)
 
  614   fileobj%domain = domain
 
  615   call string_copy(fileobj%non_mangled_path, fileobj%path)
 
  624   character(len=*), 
intent(in) :: path
 
  625   character(len=*), 
intent(in) :: mode
 
  628   character(len=*), 
intent(in), 
optional :: nc_format
 
  638                                           nc_format, fileobj%is_restart)
 
  639   if (.not. success) 
then 
  640     call error(
"error while opening file "//trim(path)//
".")
 
  651   integer, 
intent(in), 
optional :: unlim_dim_level
 
  652   character(len=*), 
intent(in), 
optional :: directory
 
  653   character(len=*), 
intent(in), 
optional :: timestamp
 
  654   character(len=*), 
intent(in), 
optional :: filename
 
  655   character(len=*), 
intent(in), 
optional :: nc_format
 
  662   character(len=256) :: new_name
 
  665   call get_new_filename(fileobj%non_mangled_path, new_name, directory, timestamp, filename)
 
  676 end module blackboxio
 
logical function, public create_diskless_netcdf_file_wrap(fileobj, pelist, path)
Wrapper to distinguish interfaces.
subroutine new_netcdf_file(fileobj, path, mode, new_fileobj, nc_format)
Make a copy of a file's metadata to support "intermediate restarts".
logical function, public create_diskless_unstructured_domain_file(fileobj, domain, path)
Create a "diskless" netcdf file to act as a buffer to support our "register         data to a file wi...
subroutine, public unstructured_write_restart_wrap(fileobj, unlim_dim_level, directory, timestamp, filename, nc_format)
Wrapper to distinguish interfaces.
subroutine, public save_domain_restart_wrap(fileobj, unlim_dim_level, directory, timestamp, filename, nc_format)
Loop through registered restart variables and write them to a netcdf file.
subroutine tempfile(filename)
Create a unique filename (poor man's version of mktemp).
logical function, public create_diskless_domain_file(fileobj, domain, path)
Create a "diskless" netcdf file to act as a buffer to support our "register         data to a file wi...
subroutine new_unstructured_domain_file(fileobj, path, mode, new_fileobj, nc_format)
Make a copy of a file's metadata to support "intermediate restarts".
subroutine get_new_filename(path, new_path, directory, timestamp, new_name)
Create a new file path.
subroutine new_domain_file(fileobj, path, mode, new_fileobj, nc_format)
Make a copy of a file's metadata to support "intermediate restarts".
subroutine, public restore_domain_state_wrap(fileobj, unlim_dim_level, directory, timestamp, filename, ignore_checksum)
Loop through registered restart variables and read them from a netcdf file.
subroutine, public netcdf_restore_state_wrap(fileobj, unlim_dim_level, directory, timestamp, filename)
Loop through registered restart variables and read them from a netcdf file.
subroutine copy_metadata(fileobj, new_fileobj)
Copy metadata from one file object to another.
subroutine, public blackboxio_init(chksz)
Accepts the namelist fms2_io_nml variables relevant to blackboxio.
subroutine, public netcdf_save_restart_wrap2(fileobj, unlim_dim_level, directory, timestamp, filename, nc_format)
Support for writing new restarts from a diskless file.
logical function create_diskless_netcdf_file(fileobj, pelist, path)
Create a "diskless" netcdf file to act as a buffer to support our "register         data to a file wi...
logical function, public file_exists(path)
Determine if a file exists.
subroutine, public error(mesg)
Print a message to stderr, then stop the program.
logical function, public string_compare(string1, string2, ignore_case)
Compare strings.
subroutine, public save_domain_restart(fileobj, unlim_dim_level)
Loop through registered restart variables and write them to a netcdf file.
logical function, public open_domain_file(fileobj, path, mode, domain, nc_format, is_restart, dont_add_res_to_filename, use_netcdf_mpi)
Open a domain netcdf file.
subroutine, public close_domain_file(fileobj)
Close a domain netcdf file.
subroutine, public restore_domain_state(fileobj, unlim_dim_level, ignore_checksum)
Loop through registered restart variables and read them from a netcdf file.
logical function, public open_unstructured_domain_file(fileobj, path, mode, domain, nc_format, is_restart, dont_add_res_to_filename)
Open a netcdf file that is associated with an unstructured domain.
subroutine, public close_unstructured_domain_file(fileobj)
Wrapper to distinguish interfaces.
netcdf unstructured domain file type.
integer function mpp_get_domain_npes(domain)
Set user stack size.
type(domain2d) function, pointer mpp_get_io_domain(domain)
Set user stack size.
Retrieve list of PEs associated with a domain decomposition. The 1D version of this call returns an a...
The domain2D type contains all the necessary information to define the global, compute and data domai...
Domain information for managing data on unstructured grids.
integer function mpp_pe()
Returns processor ID.
subroutine, public netcdf_restore_state(fileobj, unlim_dim_level)
Loop through registered restart variables and read them from a netcdf file.
subroutine, public netcdf_file_close(fileobj)
Close a netcdf file.
logical function, public netcdf_file_open(fileobj, path, mode, nc_format, pelist, is_restart, dont_add_res_to_filename)
Open a netcdf file.
subroutine, public set_netcdf_mode(ncid, mode)
Switch to the correct netcdf mode.
subroutine, public check_netcdf_code(err, msg)
Check for errors returned by netcdf.
subroutine, public netcdf_save_restart(fileobj, unlim_dim_level)
Loop through registered restart variables and write them to a netcdf file.