!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! !!
!! GNU General Public License !!
!! !!
!! This file is part of the Flexible Modeling System (FMS). !!
!! !!
!! FMS is free software; you can redistribute it and/or modify !!
!! it and are expected to follow the terms of the GNU General Public !!
!! License as published by the Free Software Foundation. !!
!! !!
!! 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 General Public License !!
!! along with FMS; if not, write to: !!
!! Free Software Foundation, Inc. !!
!! 59 Temple Place, Suite 330 !!
!! Boston, MA 02111-1307 USA !!
!! or see: !!
!! http://www.gnu.org/licenses/gpl.txt !!
!! !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module fms_mod
! <CONTACT EMAIL="Bruce.Wyman@noaa.gov">
! Bruce Wyman
! </CONTACT>
! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
! <OVERVIEW>
! The fms module provides routines that are commonly used
! by most FMS modules.
! </OVERVIEW>
! <DESCRIPTION>
! Here is a summary of the functions performed by routines
! in the fms module.
!
! 1. Output module version numbers to a common (<TT>log</TT>) file
! using a common format.<BR/>
! 2. Open specific types of files common to many FMS modules.
! These include namelist files, restart files, and 32-bit IEEE
! data files. There also is a matching interface to close the files.
! If other file types are needed the <TT>mpp_open</TT> and <TT>mpp_close</TT>
! interfaces in module <LINK SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/shared/mpp/mpp_io.html">mpp_io</LINK> must be used.<BR/>
! 3. Read and write distributed data to simple native unformatted files.
! This type of file (called a restart file) is used to checkpoint
! model integrations for a subsequent restart of the run.<BR/>
! 4. For convenience there are several routines published from
! the <LINK SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/shared/mpp/mpp.html">mpp</LINK> module. These are routines for getting processor
! numbers, commonly used I/O unit numbers, error handling, and timing sections of code.
! </DESCRIPTION>
!-----------------------------------------------------------------------
!
! A collection of commonly used routines.
!
! The routines are primarily I/O related, however, there also
! exists several simple miscellaneous utility routines.
!
!-----------------------------------------------------------------------
!
! file_exist Checks the existence of the given file name.
!
! check_nml_error Checks the iostat argument that is returned after
! reading a namelist and determines if the error
! code is valid.
!
! write_version_number Prints to the log file (or a specified unit)
! the (cvs) version id string and (cvs) tag name.
!
! error_mesg Print notes, warnings and error messages,
! terminates program for error messages.
! (use error levels NOTE,WARNING,FATAL)
!
! open_namelist_file Opens namelist file for reading only.
!
! open_restart_file Opens a file that will be used for reading or writing
! restart files with native unformatted data.
!
! open_ieee32_file Opens a file that will be used for reading or writing
! unformatted 32-bit ieee data.
!
! close_file Closes a file that was opened using
! open_namelist_file, open_restart_file, or
! open_ieee32_file.
!
! set_domain Call this routine to internally store in fms_mod the
! domain2d data type prior to calling the distributed
! data I/O routines read_data and write_data.
!
! read_data Reads distributed data from a single threaded file.
!
! write_data Writes distributed data to a single threaded file.
!
! fms_init Initializes the fms module and also the
! mpp_io module (which initializes all mpp mods).
! Will be called automatically if the user does
! not call it.
!
! fms_end Calls mpp exit routines.
!
! lowercase Convert character strings to all lower case
!
! uppercase Convert character strings to all upper case
!
! monotonic_array Determines if the real input array has
! monotonically increasing or decreasing values.
!
! string_array_index Match the input character string to a string
! in an array/list of character strings.
!
!-----------------------------------------------------------------------
!---- published routines from mpp_mod ----
!
! mpp_error, NOTE, WARNING, FATAL
! mpp_error_state
! mpp_pe, mpp_npes, mpp_root_pe
! stdin, stdout, stderr, stdlog
! mpp_chksum
!
! mpp_clock_id, mpp_clock_begin , mpp_clock_end
! MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED
! CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER,
! CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
!
!-----------------------------------------------------------------------
use mpp_mod, only: mpp_error, NOTE, WARNING, FATAL, &
mpp_set_warn_level, &
mpp_transmit, ALL_PES, &
mpp_pe, mpp_npes, mpp_root_pe, &
mpp_sync, mpp_chksum, &
mpp_clock_begin, mpp_clock_end, &
mpp_clock_id, mpp_init, mpp_exit, &
MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, &
CLOCK_COMPONENT, CLOCK_SUBCOMPONENT,&
CLOCK_MODULE_DRIVER, CLOCK_MODULE, &
CLOCK_ROUTINE, CLOCK_LOOP, &
CLOCK_INFRA, mpp_clock_set_grain, &
mpp_set_stack_size, &
stdin, stdout, stderr, stdlog, &
mpp_error_state, lowercase, &
uppercase
use mpp_domains_mod, only: domain2D, mpp_define_domains, &
mpp_update_domains, GLOBAL_DATA_DOMAIN, &
mpp_domains_init, mpp_domains_exit, &
mpp_global_field, mpp_domains_set_stack_size, &
mpp_get_compute_domain, mpp_get_global_domain, &
mpp_get_data_domain
use mpp_io_mod, only: mpp_io_init, mpp_open, mpp_close, &
MPP_ASCII, MPP_NATIVE, MPP_IEEE32, MPP_NETCDF, &
MPP_RDONLY, MPP_WRONLY, MPP_APPEND, MPP_OVERWR, &
MPP_SEQUENTIAL, MPP_DIRECT, &
MPP_SINGLE, MPP_MULTI, MPP_DELETE, mpp_io_exit, &
fieldtype, mpp_get_atts, mpp_get_info, mpp_get_fields
use fms_io_mod, only : read_data, write_data, fms_io_init, fms_io_exit, field_size, &
open_namelist_file, open_restart_file, open_ieee32_file, close_file, &
set_domain, get_domain_decomp, nullify_domain, &
open_file, open_direct_file
use memutils_mod, only: print_memuse_stats, memutils_init
use constants_mod, only: PI, RADIAN, constants_version=>version, constants_tagname=>tagname !Balaji: initialize here
implicit none
private
! routines for initialization and termination of module
public :: fms_init, fms_end
! routines for opening/closing specific types of file
public :: open_namelist_file, open_restart_file, &
open_ieee32_file, close_file, &
open_file, open_direct_file
! routines for reading/writing distributed data
public :: set_domain, read_data, write_data
public :: get_domain_decomp, field_size, nullify_domain
! miscellaneous i/o routines
public :: file_exist, check_nml_error, field_exist, &
write_version_number, error_mesg
! miscellaneous utilities (non i/o)
public :: lowercase, uppercase, string, &
string_array_index, monotonic_array
! public mpp interfaces
public :: mpp_error, NOTE, WARNING, FATAL, &
mpp_error_state, &
mpp_pe, mpp_npes, mpp_root_pe, &
stdin, stdout, stderr, stdlog, &
mpp_chksum
public :: mpp_clock_id, mpp_clock_begin, mpp_clock_end
public :: MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED
public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, &
CLOCK_MODULE_DRIVER, CLOCK_MODULE, &
CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
!Balaji
!this is published by fms and applied to any initialized clocks
!of course you can go and set the flag to SYNC or DETAILED by hand
integer, public :: clock_flag_default
! temporary interface (to be removed before next release)
public :: mpp_clock_init
!------ namelist interface -------
!------ adjustable severity level for warnings ------
logical :: read_all_pe = .true.
character(len=16) :: clock_grain = 'NONE', clock_flags='NONE'
character(len=8) :: warning_level = 'warning'
character(len=64) :: iospec_ieee32 = '-N ieee_32'
integer :: stack_size = 0
integer :: domains_stack_size = 0
logical, public :: print_memory_usage = .FALSE.
!------ namelist interface -------
! <NAMELIST NAME="fms_nml">
! <DATA NAME="clock_grain" TYPE="character" DEFAULT="'NONE'">
! The level of clock granularity used for performance timing sections
! of code. Possible values in order of increasing detail are:
! 'NONE', 'COMPONENT', 'SUBCOMPONENT', 'MODULE_DRIVER', 'MODULE', 'ROUTINE',
! 'LOOP', and 'INFRA'. Code sections are defined using routines in MPP
! module: mpp_clock_id, mpp_clock_begin, and mpp_clock_end.
! The fms module makes these routines public.
! A list of timed code sections will be printed to STDOUT.
! See the <LINK SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/shared/mpp/mpp.html">MPP</LINK>
! module for more details.
! </DATA>
! <DATA NAME="clock_flags" TYPE="character" DEFAULT="'NONE'">
! Possible values are 'NONE', 'SYNC', or 'DETAILED'.
! SYNC will give accurate information on load balance of the clocked
! portion of code.
! DETAILED also turns on detailed message-passing performance diagnosis.
! Both SYNC and DETAILED will work correctly on innermost clock nest
! and distort outer clocks, and possibly the overall code time.
! See the <LINK SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/shared/mpp/mpp.html">MPP</LINK>
! module for more details.
! </DATA>
! <DATA NAME="read_all_pe" TYPE="logical" DEFAULT="true">
! Read global data on all processors extracting local part needed (TRUE) or
! read global data on PE0 and broadcast to all PEs (FALSE).
! </DATA>
! <DATA NAME="warning_level" TYPE="character" DEFAULT="'warning'">
! Sets the termination condition for the WARNING flag to interfaces
! error_mesg/mpp_error. set warning_level = 'fatal' (program crashes for
! warning messages) or 'warning' (prints warning message and continues).
! </DATA>
! <DATA NAME="iospec_ieee32" TYPE="character" DEFAULT="'-N ieee_32'">
! iospec flag used with the open_ieee32_file interface.
! </DATA>
! <DATA NAME="stack_size" TYPE="integer" DEFAULT="0">
! The size in words of the MPP user stack. If stack_size > 0, the following
! MPP routine is called: call mpp_set_stack_size (stack_size). If stack_size
! = 0 (default) then the default size set by mpp_mod is used.
! </DATA>
! <DATA NAME="domains_stack_size" TYPE="integer" DEFAULT="0">
! The size in words of the MPP_DOMAINS user stack. If
! domains_stack_size > 0, the following MPP_DOMAINS routine is called:
! call mpp_domains_set_stack_size (domains_stack_size). If
! domains_stack_size = 0 (default) then the default size set by
! mpp_domains_mod is used.
! </DATA>
! <DATA NAME="print_memory_usage" TYPE="logical" DEFAULT=".FALSE.">
! If set to .TRUE., memory usage statistics will be printed at various
! points in the code. It is used to study memory usage, e.g to detect
! memory leaks.
! </DATA>
! </NAMELIST>
namelist /fms_nml/ read_all_pe, clock_grain, clock_flags, &
warning_level, iospec_ieee32, &
stack_size, domains_stack_size, &
print_memory_usage
!--- public interface ---
interface string
module procedure string_from_integer
module procedure string_from_real
end interface
! ---- private data for check_nml_error ----
integer, private :: num_nml_error_codes, nml_error_codes(20)
logical, private :: do_nml_error_init = .true.
private nml_error_init
! ---- version number -----
character(len=128) :: version = '$Id$'
character(len=128) :: tagname = '$Name$'
logical :: module_is_initialized = .FALSE.
contains
!#######################################################################
! <SUBROUTINE NAME="fms_init">
! <OVERVIEW>
! Initializes the FMS module and also calls the initialization routines for all
! modules in the MPP package. Will be called automatically if the user does
! not call it.
! </OVERVIEW>
! <DESCRIPTION>
! Initialization routine for the fms module. It also calls initialization routines
! for the mpp, mpp_domains, and mpp_io modules. Although this routine
! will be called automatically by other fms_mod routines, users should
! explicitly call fms_init. If this routine is called more than once it will
! return silently. There are no arguments.
! </DESCRIPTION>
! <TEMPLATE>
! call fms_init ( )
! </TEMPLATE>
! <ERROR MSG="invalid entry for namelist variable warning_level" STATUS="FATAL">
! The namelist variable warning_level must be either 'fatal' or 'warning'
! (case-insensitive).
! </ERROR>
! <ERROR MSG="invalid entry for namelist variable clock_grain" STATUS="FATAL">
! The namelist variable clock_grain must be one of the following values:
! 'NONE', 'COMPONENT', 'SUBCOMPONENT', 'MODULE_DRIVER', 'MODULE', 'ROUTINE',
! 'LOOP', or 'INFRA' (case-insensitive).
! </ERROR>
! initializes the fms module/package
! also calls mpp initialization routines and reads fms namelist
subroutine fms_init (localcomm )
integer, intent(in), optional :: localcomm
integer :: unit, ierr, io, timing_grain
if (module_is_initialized) return ! return silently if already called
module_is_initialized = .true.
!---- initialize mpp routines ----
if(present(localcomm)) then
call mpp_init(localcomm=localcomm)
else
call mpp_init()
endif
call mpp_domains_init
call fms_io_init
!---- read namelist input ----
call nml_error_init ! first initialize namelist iostat error codes
if (file_exist('input.nml')) then
unit = open_namelist_file ( )
ierr=1; do while (ierr /= 0)
read (unit, nml=fms_nml, iostat=io, end=10)
ierr = check_nml_error(io,'fms_nml') ! also initializes nml error codes
enddo
10 call mpp_close (unit)
endif
!---- define mpp stack sizes if non-zero -----
if ( stack_size > 0) call mpp_set_stack_size ( stack_size)
if (domains_stack_size > 0) call mpp_domains_set_stack_size (domains_stack_size)
!---- set severity level for warnings ----
select case( trim(lowercase(warning_level)) )
case( 'fatal' )
call mpp_set_warn_level ( FATAL )
case( 'warning' )
call mpp_set_warn_level ( WARNING )
case default
call error_mesg ( 'fms_init', &
'invalid entry for namelist variable warning_level', FATAL )
end select
!--- set granularity for timing code sections ---
select case( trim(uppercase(clock_grain)) )
case( 'NONE' )
call mpp_clock_set_grain (0)
case( 'COMPONENT' )
call mpp_clock_set_grain (CLOCK_COMPONENT)
case( 'SUBCOMPONENT' )
call mpp_clock_set_grain (CLOCK_SUBCOMPONENT)
case( 'MODULE_DRIVER' )
call mpp_clock_set_grain (CLOCK_MODULE_DRIVER)
case( 'MODULE' )
call mpp_clock_set_grain (CLOCK_MODULE)
case( 'ROUTINE' )
call mpp_clock_set_grain (CLOCK_ROUTINE)
case( 'LOOP' )
call mpp_clock_set_grain (CLOCK_LOOP)
case( 'INFRA' )
call mpp_clock_set_grain (CLOCK_INFRA)
case default
call error_mesg ( 'fms_init', &
'invalid entry for namelist variable clock_grain', FATAL )
end select
!Balaji
select case( trim(uppercase(clock_flags)) )
case( 'NONE' )
clock_flag_default = 0
case( 'SYNC' )
clock_flag_default = MPP_CLOCK_SYNC
case( 'DETAILED' )
clock_flag_default = MPP_CLOCK_DETAILED
case default
call error_mesg ( 'fms_init', &
'invalid entry for namelist variable clock_flags', FATAL )
end select
!--- write version info and namelist to logfile ---
call write_version_number (version, tagname)
if (mpp_pe() == mpp_root_pe()) then
write (stdlog(), nml=fms_nml)
write (stdlog(),*) 'nml_error_codes=', nml_error_codes(1:num_nml_error_codes)
endif
call memutils_init( print_memory_usage )
call print_memuse_stats('fms_init')
call write_version_number (constants_version,constants_tagname)
PI = 4.0*ATAN(1.0)
RADIAN = 180.0/PI
end subroutine fms_init
! </SUBROUTINE>
!#######################################################################
! <SUBROUTINE NAME="fms_end">
! <OVERVIEW>
! Calls the termination routines for all modules in the MPP package.
! </OVERVIEW>
! <DESCRIPTION>
! Termination routine for the fms module. It also calls destructor routines
! for the mpp, mpp_domains, and mpp_io modules. If this routine is called
! more than once it will return silently. There are no arguments.
! </DESCRIPTION>
! <TEMPLATE>
! call fms_end ( )
! </TEMPLATE>
! terminates the fms module/package
! also calls mpp destructor routines
subroutine fms_end ( )
if (.not.module_is_initialized) return ! return silently
! call fms_io_exit !now called from coupler_end
call mpp_io_exit
print *,'in fms_end, after mpp_io_eixt'
call mpp_domains_exit
print *,'in fms_end, after mpp_domains_eixt'
call mpp_exit
print *,'in fms_end, after mpp_eixt'
module_is_initialized =.FALSE.
end subroutine fms_end
! </SUBROUTINE>
!#######################################################################
! <FUNCTION NAME="file_exist">
! <OVERVIEW>
! check if a given field name exists in a given file name.
! </OVERVIEW>
! <DESCRIPTION>
! check if a given field name exists in a given file name.
! If the field_name string has zero length or the
! first character is blank return a false result.
! if the file file_name don't exist, return a false result.
! </DESCRIPTION>
! <TEMPLATE>
! field_exist ( file_name, field_name )
! </TEMPLATE>
! <IN NAME="file_name" TYPE="character" >
! A file name (or path name) that is checked for existence.
! </IN>
! <IN NAME="field_name" TYPE="character" >
! A field name that is checked for existence.
! </IN>
! <OUT NAME="" TYPE="logical" >
! This function returns a logical result. If field exists in the
! file file_name, the result is true, otherwise false is returned.
! If the length of character string "field_name" is zero or the first
! character is blank, then the returned value will be false.
! if the file file_name don't exist, return a false result.
! </OUT>
function field_exist (file_name, field_name)
character(len=*), intent(in) :: file_name
character(len=*), intent(in) :: field_name
logical :: field_exist
integer :: unit, ndim, nvar, natt, ntime, i
character(len=64) :: name
type(fieldtype), allocatable :: fields(:)
field_exist = .false.
if(.not.file_exist(file_name)) return
if (len_trim(field_name) == 0) return
if (field_name(1:1) == ' ') return
!--- open the file file_name
call mpp_open(unit, trim(file_name), MPP_RDONLY, MPP_NETCDF, threading=MPP_MULTI, &
fileset = MPP_SINGLE)
call mpp_get_info(unit, ndim, nvar, natt, ntime)
allocate(fields(nvar))
call mpp_get_fields(unit,fields)
do i=1, nvar
call mpp_get_atts(fields(i),name=name)
if(trim(name) == trim(field_name)) field_exist = .true.
enddo
deallocate(fields)
call mpp_close(unit)
return
end function field_exist
! </FUNCTION>
!#######################################################################
! check the existence of the given file name
! if the file_name string has zero length or the
! first character is blank return a false result
! <FUNCTION NAME="file_exist">
! <OVERVIEW>
! Checks the existence of a given file name.
! </OVERVIEW>
! <DESCRIPTION>
! Checks the existence of the given file name.
! If the file_name string has zero length or the
! first character is blank return a false result.
! </DESCRIPTION>
! <TEMPLATE>
! file_exist ( file_name )
! </TEMPLATE>
! <IN NAME="file_name" TYPE="character" >
! A file name (or path name) that is checked for existence.
! </IN>
! <OUT NAME="" TYPE="logical" >
! This function returns a logical result. If file_name exists the result
! is true, otherwise false is returned.
! If the length of character string "file_name" is zero or the first
! character is blank, then the returned value will be false.
! When reading a file, this function is often used in conjunction with
! routine open_file.
! </OUT>
! <ERROR MSG="set_domain not called" STATUS="FATAL">
! Before calling write_data you must first call set_domain with domain2d data
! type associated with the distributed data you are writing.
! </ERROR>
function file_exist (file_name)
character(len=*), intent(in) :: file_name
logical file_exist
file_exist = .false.
if (len_trim(file_name) == 0) return
if (file_name(1:1) == ' ') return
inquire (file=trim(file_name), exist=file_exist)
end function file_exist
! </FUNCTION>
!#######################################################################
! <SUBROUTINE NAME="error_mesg">
! <OVERVIEW>
! Print notes, warnings and error messages; terminates program for warning
! and error messages. (use error levels NOTE,WARNING,FATAL, see example below)
! </OVERVIEW>
! <DESCRIPTION>
! Print notes, warnings and error messages; and terminates the program for
! error messages. This routine is a wrapper around mpp_error, and is provided
! for backward compatibility. This module also publishes mpp_error,
! <B>users should try to use the mpp_error interface</B>.
! </DESCRIPTION>
! <TEMPLATE>
! call error_mesg ( routine, message, level )
! </TEMPLATE>
! <IN NAME="routine" TYPE="character" >
! Routine name where the warning or error has occurred.
! </IN>
! <IN NAME="message" TYPE="character" >
! Warning or error message to be printed.
! </IN>
! <IN NAME="level" TYPE="integer" >
! Level of severity; set to NOTE, WARNING, or FATAL Termination always occurs
! for FATAL, never for NOTE, and is settable for WARNING (see namelist).
! </IN>
! <NOTE>
!
! Examples:
! <PRE>
! use fms_mod, only: error_mesg, FATAL, NOTE
! call error_mesg ('fms_mod', 'initialization not called', FATAL)
! call error_mesg ('fms_mod', 'fms_mod message', NOTE)
! </PRE>
! </NOTE>
! wrapper for the mpp error handler
! users should try to use the mpp_error interface
subroutine error_mesg (routine, message, level)
character(len=*), intent(in) :: routine, message
integer, intent(in) :: level
! input:
! routine name of the calling routine (character string)
! message message written to output (character string)
! level set to NOTE, MESSAGE, or FATAL (integer)
if (.not.module_is_initialized) call fms_init ( )
call mpp_error ( routine, message, level )
end subroutine error_mesg
! </SUBROUTINE>
!#######################################################################
! <FUNCTION NAME="check_nml_error">
! <OVERVIEW>
! Checks the iostat argument that is returned after reading a namelist
! and determines if the error code is valid.
! </OVERVIEW>
! <DESCRIPTION>
! The FMS allows multiple namelist records to reside in the same file.
! Use this interface to check the iostat argument that is returned after
! reading a record from the namelist file. If an invalid iostat value
! is detected this routine will produce a fatal error. See the NOTE below.
! </DESCRIPTION>
! <TEMPLATE>
! check_nml_error ( iostat, nml_name )
! </TEMPLATE>
! <IN NAME="iostat" TYPE="integer" >
! The iostat value returned when reading a namelist record.
! </IN>
! <IN NAME="nml_name" TYPE="character" >
! The name of the namelist. This name will be printed if an error is
! encountered, otherwise the name is not used.
! </IN>
! <OUT NAME="" TYPE="integer" >
! This function returns the input iostat value (integer) if it is an
! allowable error code. If the iostat error code is not
! allowable, an error message is printed and the program terminated.
! </OUT>
! <NOTE>
! Some compilers will return non-zero iostat values when reading through
! files with multiple namelist. This routine
! will try skip these errors and only terminate for true namelist errors.
!
! Examples
!
! The following example checks if a file exists, reads a namelist input
! from that file, and checks for errors in that
! namelist. When the correct namelist is read and it has no errors the
! routine check_nml_error will return zero and the while loop will exit.
! This code segment should be used to read namelist files.
! <PRE>
! integer :: unit, ierr, io
!
! if ( file_exist('input.nml') ) then
! unit = open_namelist_file ( )
! ierr=1
! do while (ierr /= 0)
! read (unit, nml=moist_processes_nml, iostat=io, end=10)
! ierr = check_nml_error(io,'moist_processes_nml')
! enddo
! 10 call close_file (unit)
! endif
! </PRE>
! </NOTE>
! <ERROR MSG="while reading namelist ...., iostat = ####" STATUS="FATAL">
! There was an error message reading the namelist specified. Carefully
! examine all namelist variables for
! misspellings of type mismatches (e.g., integer vs. real).
! </ERROR>
! used to check the iostat argument that is
! returned after reading a namelist
! see the online documentation for how this routine might be used
function check_nml_error (iostat, nml_name) result (error_code)
integer, intent(in) :: iostat
character(len=*), intent(in) :: nml_name
integer error_code, i
character(len=128) :: err_str
if (.not.module_is_initialized) call fms_init ( )
error_code = iostat
do i = 1, num_nml_error_codes
if (error_code == nml_error_codes(i)) return
enddo
! ------ fatal namelist error -------
! ------ only on root pe ----------------
if (mpp_pe() == mpp_root_pe()) then
write (err_str,*) 'while reading namelist ', &
trim(nml_name), ', iostat = ',error_code
call error_mesg ('check_nml_error in fms_mod', err_str, FATAL)
call error_mesg ('check_nml_error in fms_mod', err_str, FATAL)
call mpp_sync() ! In principal, this sync should not be necessary
! as mpp_error's call to MPI_ABORT and ABORT should
! kill all associated processes. Still...
else
call mpp_sync()
endif
end function check_nml_error
! </FUNCTION>
!-----------------------------------------------------------------------
! private routine for initializing allowable error codes
subroutine nml_error_init
! some compilers return non-zero iostat values while
! reading through files with multiple namelist records
! this routines "attempts" to identify the iostat values associated
! with records not belonging to the requested namelist
integer unit, io, ir
real :: a=1.
integer :: b=1
logical :: c=.true.
character(len=8) :: d='testing'
namelist /b_nml/ a,b,c,d
nml_error_codes(1) = 0
! ---- create dummy namelist file that resembles actual ----
! ---- (each pe has own copy) ----
call mpp_open (unit, '_read_error.nml', form=MPP_ASCII, &
action=MPP_OVERWR, access=MPP_SEQUENTIAL, &
threading=MPP_MULTI)
! ---- due to namelist bug this will not always work ---
write (unit, 10)
10 format (' ', &
/' &a_nml a=1. /', &
/'#------------------', &
/' &b_nml a=5., b=0, c=.false., d=''test'', &end')
call mpp_close (unit)
! ---- read namelist files and save error codes ----
call mpp_open (unit, '_read_error.nml', form=MPP_ASCII, &
action=MPP_RDONLY, access=MPP_SEQUENTIAL, &
threading=MPP_MULTI)
ir=1; io=1; do
read (unit, nml=b_nml, iostat=io, end=20)
if (io == 0) exit
ir=ir+1; nml_error_codes(ir)=io
enddo
20 call mpp_close (unit, action=MPP_DELETE)
num_nml_error_codes = ir
!del if (mpp_pe() == mpp_root_pe()) &
!del print *, 'PE,nml_error_codes=',mpp_pe(), nml_error_codes(1:ir)
do_nml_error_init = .false.
end subroutine nml_error_init
!#######################################################################
! <SUBROUTINE NAME="write_version_number">
! <OVERVIEW>
! Prints to the log file (or a specified unit) the (cvs) version id string and
! (cvs) tag name.
! </OVERVIEW>
! <DESCRIPTION>
! Prints to the log file (stdlog) or a specified unit the (cvs) version id string
! and (cvs) tag name.
! </DESCRIPTION>
! <TEMPLATE>
! call write_version_number ( version [, tag, unit] )
! </TEMPLATE>
! <IN NAME="version" TYPE="character(len=*)">
! string that contains routine name and version number.
! </IN>
! <IN NAME="tag" TYPE="character(len=*)">
! The tag/name string, this is usually the Name string
! returned by CVS when checking out the code.
! </IN>
! <IN NAME="unit" TYPE="integer">
! The Fortran unit number of an open formatted file. If this unit number
! is not supplied the log file unit number is used (stdlog).
! </IN>
! prints module version number to the log file of specified unit number
subroutine write_version_number (version, tag, unit)
! in: version = string that contains routine name and version number
!
! optional in:
! tag = cvs tag name that code was checked out with
! unit = alternate unit number to direct output
! (default: unit=stdlog)
character(len=*), intent(in) :: version
character(len=*), intent(in), optional :: tag
integer, intent(in), optional :: unit
integer :: logunit
if (.not.module_is_initialized) call fms_init ( )
logunit = stdlog()
if (present(unit)) then
logunit = unit
else
! only allow stdlog messages on root pe
if ( mpp_pe() /= mpp_root_pe() ) return
endif
if (present(tag)) then
write (logunit,'(/,80("="),/(a))') trim(version), trim(tag)
else
write (logunit,'(/,80("="),/(a))') trim(version)
endif
end subroutine write_version_number
! </SUBROUTINE>
!#######################################################################
! <FUNCTION NAME="string_array_index">
! <OVERVIEW>
! match the input character string to a string
! in an array/list of character strings
! </OVERVIEW>
! <DESCRIPTION>
! Tries to find a match for a character string in a list of character strings.
! The match is case sensitive and disregards blank characters to the right of
! the string.
! </DESCRIPTION>
! <TEMPLATE>
! string_array_index ( string, string_array [, index] )
! </TEMPLATE>
! <IN NAME="string" TYPE="character(len=*), scalar" >
! Character string of arbitrary length.
! </IN>
! <IN NAME="string_array" TYPE="character(len=*)" DIM="(:)">
! Array/list of character strings.
! </IN>
! <OUT NAME="index" TYPE="integer" >
! The index of string_array where the first match was found. If
! no match was found then index = 0.
! </OUT>
! <OUT NAME="string_array_index" TYPE="logical" >
! If an exact match was found then TRUE is returned, otherwise FALSE is returned.
! </OUT>
! <NOTE>
! Examples
! <PRE>
! string = "def"
! string_array = (/ "abcd", "def ", "fghi" /)
! string_array_index ( string, string_array, index )
! Returns: TRUE, index = 2
! </PRE>
! </NOTE>
! match the input character string to a string
! in an array/list of character strings
function string_array_index ( string, string_array, index ) result (found)
character(len=*), intent(in) :: string, string_array(:)
integer, optional, intent(out) :: index
logical :: found
integer :: i
! initialize this function to false
! loop thru string_array and exit when a match is found
found = .false.
if (present(index)) index = 0
do i = 1, size(string_array(:))
! found a string match ?
if ( trim(string) == trim(string_array(i)) ) then
found = .true.
if (present(index)) index = i
exit
endif
enddo
end function string_array_index
! </FUNCTION>
!#######################################################################
! <FUNCTION NAME="monotonic_array">
! <OVERVIEW>
! Determines if a real input array has monotonically increasing or
! decreasing values.
! </OVERVIEW>
! <DESCRIPTION>
! Determines if the real input array has monotonically increasing or
! decreasing values.
! </DESCRIPTION>
! <TEMPLATE>
! monotonic_array ( array [, direction] )
! </TEMPLATE>
! <IN NAME="array" TYPE="real" DIM="(:)">
! An array of real values. If the size(array) < 2 this function
! assumes the array is not monotonic, no fatal error will occur.
! </IN>
! <OUT NAME="direction" TYPE="integer" >
! If the input array is:
! >> monotonic (small to large) then direction = +1.
! >> monotonic (large to small) then direction = -1.
! >> not monotonic then direction = 0.
! </OUT>
! <OUT NAME="monotonic_array" TYPE="logical" >
! If the input array of real values either increases or decreases monotonically
! then TRUE is returned, otherwise FALSE is returned.
! </OUT>
! determines if the real input array has
! monotonically increasing or decreasing values
function monotonic_array ( array, direction )
real, intent(in) :: array(:)
integer, intent(out), optional :: direction
logical :: monotonic_array
integer :: i
! initialize
monotonic_array = .false.
if (present(direction)) direction = 0
! array too short
if ( size(array(:)) < 2 ) return
! ascending
if ( array(1) < array(size(array(:))) ) then
do i = 2, size(array(:))
if (array(i-1) < array(i)) cycle
return
enddo
monotonic_array = .true.
if (present(direction)) direction = +1
! descending
else
do i = 2, size(array(:))
if (array(i-1) > array(i)) cycle
return
enddo
monotonic_array = .true.
if (present(direction)) direction = -1
endif
end function monotonic_array
! </FUNCTION>
!#######################################################################
function string_from_integer(n)
integer, intent(in) :: n
character(len=16) :: string_from_integer
write(string_from_integer,*) n
return
end function string_from_integer
!#######################################################################
function string_from_real(a)
real, intent(in) :: a
character(len=32) :: string_from_real
write(string_from_real,*) a
return
end function string_from_real
!#######################################################################
!##### temporary interface for backward compatibility ######
! remove before next release
function mpp_clock_init ( name, level, flags ) result (id)
character(len=*), intent(in) :: name
integer, intent(in) :: level
integer, optional, intent(in) :: flags
integer :: id
id = 0
if (mpp_pe() == mpp_root_pe()) call error_mesg ( 'fms_init', &
'interface mpp_clock_init no longer valid: name='//trim(name), NOTE)
end function mpp_clock_init
!#######################################################################
end module fms_mod
! <INFO>
! <BUG>
! Namelist error checking may not work correctly with some compilers.
!
! Users should beware when mixing Fortran reads and read_data calls. If a
! Fortran read follows read_data and namelist variable read_all_pe = FALSE
! (not the default), then the code will fail. It is safest if Fortran reads
! precede calls to read_data.
! </BUG>
! <ERROR MSG="unexpected EOF" STATUS="FATAL">
! An unexpected end-of-file was encountered in a read_data call.
! You may want to use the optional end argument to detect the EOF.
! </ERROR>
! <NOTE>
! 1) If the <B>MPP</B> or <B>MPP_DOMAINS</B> stack size is exceeded the
! program will terminate after printing the required size.
!
! 2) When running on a very small number of processors or for high
! resolution models the default domains_stack_size will
! probably be insufficient.
!
! 3) The following performance routines in the <B>MPP</B> module are published by this module.
!<PRE>
! mpp_clock_id, mpp_clock_begin, mpp_clock_end
!</PRE>
! and associated parameters that are published:
!<PRE>
! MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, CLOCK_COMPONENT, CLOCK_SUBCOMPONENT,
! CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
!</PRE>
!
! 4) Here is an example of how to time a section of code.<BR/>
!<PRE>
! use fms_mod, only: mpp_clock_id, mpp_clock_begin, &
! mpp_clock_end. MPP_CLOCK_SYNC, &
! CLOCK_MODULE_DRIVER
! integer :: id_mycode
!
! id_mycode = mpp_clock_id ('mycode loop', flags=MPP_CLOCK_SYNC, grain=CLOCK_MODULE_DRIVER)
! call mpp_clock_begin (id_mycode)
! :
! :
! ~~ this code will be timed ~~
! :
! :
! call mpp_clock_end (id_mycode)
! </PRE>
! Note: <TT>CLOCK_MODULE_DRIVER</TT> can be replaced with
! CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE,
! CLOCK_LOOP, or CLOCK_INFRA.
!
! </NOTE>
! <FUTURE>
! NetCDF facilities for reading and writing restart files and (IEEE32)
! data files.
! </FUTURE>
! <FUTURE>
! May possible split the FMS module into two modules.
!
! i.general utilities (FMS_MOD) <BR/>
! ii.I/O utilities (FMS_IO_MOD)
! </FUTURE>
! </INFO>