mpp_io_misc.inc

! -*-f90-*-
 
!***********************************************************************
!*                   GNU Lesser General Public License
!*
!* This file is part of the GFDL Flexible Modeling System (FMS).
!*
!* FMS is free software: you can redistribute it and/or modify it under
!* the terms of the GNU Lesser General Public License as published by
!* the Free Software Foundation, either version 3 of the License, or (at
!* your option) any later version.
!*
!* FMS is distributed in the hope that it will be useful, but WITHOUT
!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
!* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
!* for more details.
!*
!* You should have received a copy of the GNU Lesser General Public
!* License along with FMS.  If not, see <http://www.gnu.org/licenses/>.
!***********************************************************************
!> @file
!> @brief Misc. routines including initialization and finalization of @ref mpp_io_mod
 
!> @addtogroup mpp_io_mod
!> @{
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
!               mpp_io_init: initialize parallel I/O                   !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
! <SUBROUTINE NAME="mpp_io_init">
!   <OVERVIEW>
!    Initialize <TT>mpp_io_mod</TT>.
!   </OVERVIEW>
!   <DESCRIPTION>
!    Called to initialize the <TT>mpp_io_mod</TT> package. Sets the range
!    of valid fortran units and initializes the <TT>mpp_file</TT> array of
!    <TT>type(filetype)</TT>.  <TT>mpp_io_init</TT> will call <TT>mpp_init</TT> and
!    <TT>mpp_domains_init</TT>, to make sure its parent modules have been
!    initialized. (Repeated calls to the <TT>init</TT> routines do no harm,
!    so don't worry if you already called it).
!   </DESCRIPTION>
!   <TEMPLATE>
!    call mpp_io_init( flags, maxunit )
!   </TEMPLATE>
!   <IN NAME="flags" TYPE="integer"></IN>
!   <IN NAME="maxunit" TYPE="integer"></IN>
! </SUBROUTINE>
 
    subroutine mpp_io_init( flags, maxunit )
      integer, intent(in), optional :: flags, maxunit
      integer                       :: io_status, unit
      integer                       :: logunit, outunit, inunit, errunit
      logical                       :: opened
      real(r8_kind)             :: doubledata = 0
      real                          :: realarray(4)
 
      if( module_is_initialized )return
 
!initialize IO package: initialize mpp_file array, set valid range of units for fortran IO
 
      call mpp_init(flags)           !if mpp_init has been called, this call will merely return
      pe = mpp_pe()
      npes = mpp_npes()
      call mpp_domains_init(flags)
 
      maxunits = _max_file_units
      if( PRESENT(maxunit) )maxunits = maxunit
      if( PRESENT(flags) )then
          debug   = flags.EQ.mpp_debug
          verbose = flags.EQ.mpp_verbose .OR. debug
      end if
 
      !--- namelist
      read (input_nml_file, mpp_io_nml, iostat=io_status)
      if (io_status > 0) then
         call mpp_error(fatal,'=>mpp_io_init: Error reading mpp_io_nml')
      endif
 
 
      outunit = stdout(); logunit=stdlog()
      write(outunit, mpp_io_nml)
      write(logunit, mpp_io_nml)
 
      unit_begin = 103
      unit_end = maxunits
 
!--- check the deflate level, set deflate = 1 if deflate_level is greater than equal to 0
      if(deflate_level .GE. 0) deflate = 1
      if(deflate .NE. 0) then
         if(deflate_level <0 .OR. deflate > 9) then
            call mpp_error(fatal, "mpp_io_mod(mpp_io_init): mpp_io_nml variable must be between 0 and 9 when set")
         endif
      endif
 
! determine the pack_size
      pack_size = size(transfer(doubledata, realarray))
      if( pack_size .NE. 1 .AND. pack_size .NE. 2) call mpp_error(fatal, &
         & 'mpp_io_mod(mpp_io_init): pack_size should be 1 or 2')
 
!initialize default_field
      default_field%name = 'noname'
      default_field%units = 'nounits'
      default_field%longname = 'noname'
      default_field%id = -1
      default_field%type = -1
      default_field%natt = -1
      default_field%ndim = -1
      default_field%checksum = 0
!largest possible 4-byte reals
      default_field%min = -huge(1._4)
      default_field%max =  huge(1._4)
      default_field%missing = mpp_fill_double ! now using netcdf:NF_FILL_DOUBLE instead of -1e36
      default_field%fill = mpp_fill_double ! now using netcdf:NF_FILL_DOUBLE instead of -1e36
      default_field%scale = 1.0
      default_field%add = 0.0
      default_field%pack = 1
      default_field%time_axis_index = -1 !this value will never match any index
! Initialize default axis
      default_axis%name = 'noname'
      default_axis%units = 'nounits'
      default_axis%longname = 'noname'
      default_axis%cartesian = 'none'
      default_axis%compressed = 'unspecified'
      default_axis%calendar = 'unspecified'
      default_axis%sense = 0
      default_axis%len = -1
      default_axis%id = -1
      default_axis%did = -1
      default_axis%type = -1
      default_axis%natt = -1
! Initialize default attribute
      default_att%name = 'noname'
      default_att%type = -1
      default_att%len = -1
      default_att%catt = 'none'
 
!up to MAXUNITS fortran units and MAXUNITS netCDF units are supported
!file attributes (opened, format, access, threading, fileset) are saved against the unit number
!external handles to netCDF units are saved from maxunits+1:2*maxunits
      allocate( mpp_file(nullunit:2*maxunits) ) !starts at NULLUNIT=-1, used by non-participant PEs in
                                                !! single-threaded I/O
      mpp_file(:)%name   = ' '
      mpp_file(:)%action    = -1
      mpp_file(:)%format    = -1
      mpp_file(:)%threading = -1
      mpp_file(:)%fileset   = -1
      mpp_file(:)%record    = -1
      mpp_file(:)%ncid      = -1
      mpp_file(:)%opened = .false.
      mpp_file(:)%initialized = .false.
      mpp_file(:)%write_on_this_pe = .false.
      mpp_file(:)%io_domain_exist = .false.
      mpp_file(:)%time_level = 0
      mpp_file(:)%time = nulltime
      mpp_file(:)%id = -1
      mpp_file(:)%valid = .false.
      mpp_file(:)%ndim = -1
      mpp_file(:)%nvar = -1
!NULLUNIT "file" is always single-threaded, open and initialized (to pass checks in mpp_write)
      mpp_file(nullunit)%threading = mpp_single
      mpp_file(nullunit)%opened = .true.
      mpp_file(nullunit)%valid  = .true.
      mpp_file(nullunit)%initialized = .true.
!! Declare the stdunits to be open
!! Because the stdunits are created with the newunit intrinsic function in some cases,
!! only open up an mpp_file array for units that are within the allocated scope of mpp_file
      if (outunit > nullunit .AND. outunit < 2*maxunits) mpp_file(outunit)%opened = .true.
      if (logunit > nullunit .AND. logunit < 2*maxunits) mpp_file(logunit)%opened = .true.
      inunit  = stdin()
      if (inunit > nullunit .AND. inunit < 2*maxunits) mpp_file(inunit)%opened  = .true.
      errunit = stderr()
      if (errunit > nullunit .AND. errunit < 2*maxunits) mpp_file(errunit)%opened = .true.
 
      if( pe.EQ.mpp_root_pe() )then
          unit = stdlog()  ! PGI compiler does not like stdlog() doing I/O within write call
          write( unit,'(/a)' )'MPP_IO module '//trim(version)
#ifdef use_netCDF
          text = nf_inq_libvers()
          write( unit,'(/a)' )'Using netCDF library version '//trim(text)
#endif
      endif
 
      call mpp_io_set_stack_size(131072) ! default initial value
      call mpp_sync()
      if( io_clocks_on )then
          mpp_read_clock  = mpp_clock_id( 'mpp_read')
          mpp_write_clock  = mpp_clock_id( 'mpp_write')
          mpp_open_clock  = mpp_clock_id( 'mpp_open')
          mpp_close_clock  = mpp_clock_id( 'mpp_close')
      endif
      module_is_initialized = .true.
      return
    end subroutine mpp_io_init
 
 
! <SUBROUTINE NAME="mpp_io_exit">
!   <OVERVIEW>
!    Exit <TT>mpp_io_mod</TT>.
!   </OVERVIEW>
!   <DESCRIPTION>
!    It is recommended, though not at present required, that you call this
!    near the end of a run. This will close all open files that were opened
!    with <LINK SRC="#mpp_open"><TT>mpp_open</TT></LINK>. Files opened otherwise
!    are not affected.
!   </DESCRIPTION>
!   <TEMPLATE>
!    call mpp_io_exit()
!   </TEMPLATE>
! </SUBROUTINE>
 
    subroutine mpp_io_exit(string)
      character(len=*), optional :: string
      integer :: unit,istat
      logical :: dosync
 
      if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_IO_EXIT: must first call mpp_io_init.' )
      dosync = .true.
      if( PRESENT(string) )then
          dosync = .NOT.( trim(string).EQ.'NOSYNC' )
      end if
!close all open fortran units
      do unit = unit_begin,unit_end
         if( mpp_file(unit)%opened )FLUSH(unit)
      end do
      if( dosync )call mpp_sync()
      do unit = unit_begin,unit_end
         if( mpp_file(unit)%opened )close(unit)
      end do
#ifdef use_netCDF
!close all open netCDF units
      do unit = maxunits+1,2*maxunits
         if( mpp_file(unit)%opened )error = nf_close(mpp_file(unit)%ncid)
      end do
#endif
 
!      call mpp_max(mpp_io_stack_hwm)
 
      if( pe.EQ.mpp_root_pe() )then
!          write( stdout,'(/a)' )'Exiting MPP_IO module...'
!          write( stdout,* )'MPP_IO_STACK high water mark=', mpp_io_stack_hwm
      end if
      deallocate(mpp_file)
      module_is_initialized = .false.
      return
    end subroutine mpp_io_exit
 
 
    subroutine netcdf_err( err, file, axis, field, attr, string )
      integer, intent(in) :: err
      type(filetype), optional :: file
      type(axistype), optional :: axis
      type(fieldtype), optional :: field
      type(atttype), optional :: attr
      character(len=*), optional :: string
      character(len=256) :: errmsg
 
#ifdef use_netCDF
      if( err.EQ.nf_noerr )return
      errmsg = nf_strerror(err)
      if( PRESENT(file) )errmsg = trim(errmsg)//' File='//file%name
      if( PRESENT(axis) )errmsg = trim(errmsg)//' Axis='//axis%name
      if( PRESENT(field) )errmsg = trim(errmsg)//' Field='//field%name
      if( PRESENT(attr) )errmsg = trim(errmsg)//' Attribute='//attr%name
      if( PRESENT(string) )errmsg = trim(errmsg)//string
      call mpp_io_exit('NOSYNC')        !make sure you close all open files
      call mpp_error( fatal, 'NETCDF ERROR: '//trim(errmsg) )
#endif
      return
    end subroutine netcdf_err
 
 
    subroutine mpp_flush(unit)
!flush the output on a unit, syncing with disk
      integer, intent(in) :: unit
 
      if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_FLUSH: must first call mpp_io_init.' )
      if( .NOT.mpp_file(unit)%write_on_this_pe) return
      if( .NOT.mpp_file(unit)%opened ) call mpp_error( fatal, 'MPP_FLUSH: invalid unit number.' )
      if( .NOT.mpp_file(unit)%initialized )call mpp_error( fatal, &
         &  'MPP_FLUSH: cannot flush a file during writing of metadata.' )
 
      if( mpp_file(unit)%format.EQ.mpp_netcdf )then
#ifdef use_netCDF
          error = nf_sync(mpp_file(unit)%ncid); call netcdf_err( error, mpp_file(unit) )
#endif
      else
          FLUSH(unit)
      end if
      return
    end subroutine mpp_flush
 
   !> Return the maximum number of MPP file units available.
   !!
   !! maxunits is a mpp_io_mod module variable and defines the maximum number
   !! of Fortran file units that can be open simultaneously.  mpp_get_maxunits
   !! simply returns this number.
   integer function mpp_get_maxunits()
      mpp_get_maxunits = maxunits
   end function mpp_get_maxunits
 
    logical function do_cf_compliance()
      do_cf_compliance = cf_compliance
    end function do_cf_compliance
!> @}