fms/fms.F90

   1 !***********************************************************************
   2 !*                   GNU Lesser General Public License
   3 !*
   4 !* This file is part of the GFDL Flexible Modeling System (FMS).
   5 !*
   6 !* FMS is free software: you can redistribute it and/or modify it under
   7 !* the terms of the GNU Lesser General Public License as published by
   8 !* the Free Software Foundation, either version 3 of the License, or (at
   9 !* your option) any later version.
  10 !*
  11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
  12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 !* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 !* for more details.
  15 !*
  16 !* You should have received a copy of the GNU Lesser General Public
  17 !* License along with FMS.  If not, see <http://www.gnu.org/licenses/>.
  18 !***********************************************************************
  19 !> @defgroup fms_mod fms_mod
  20 !> @ingroup fms
  21 !! @brief The fms module provides routines that are commonly used
  22 !!   by most FMS modules.
  23 !> @author Bruce Wyman
  24 !!
  25 !> Here is a summary of the functions performed by routines
  26 !!     in the fms module.
  27 !!
  28 !! 1. Output module version numbers to a common (<TT>log</TT>) file
  29 !!     using a common format.<BR/>
  30 !! 2. Open specific types of files common to many FMS modules.
  31 !!     These include namelist files, restart files, and 32-bit IEEE
  32 !!     data files. There also is a matching interface to close the files.
  33 !!     If other file types are needed the <TT>mpp_open</TT> and <TT>mpp_close</TT>
  34 !!     interfaces in module @ref mpp_io_mod must be used.<BR/>
  35 !! 3. Read and write distributed data to simple native unformatted files.
  36 !!     This type of file (called a restart file) is used to checkpoint
  37 !!     model integrations for a subsequent restart of the run.<BR/>
  38 !! 4. For convenience there are several routines published from
  39 !!     the @ref mpp module. These are routines for getting processor
  40 !!     numbers, commonly used I/O unit numbers, error handling, and timing sections of code.
  41
  42 !> @file
  43 !> @brief File for @ref fms_mod
  44
  45 !> @addtogroup fms_mod
  46 !> @{
  47 module fms_mod
  48
  49 !-----------------------------------------------------------------------
  50 !
  51 !         A collection of commonly used routines.
  52 !
  53 !  The routines are primarily I/O related, however, there also
  54 !  exists several simple miscellaneous utility routines.
  55 !
  56 !-----------------------------------------------------------------------
  57 !
  58 !  file_exist         Checks the existence of the given file name.
  59 !
  60 !  check_nml_error    Checks the iostat argument that is returned after
  61 !                     reading a namelist and determines if the error
  62 !                     code is valid.
  63 !
  64 !  write_version_number  Prints to the log file (or a specified unit)
  65 !                        the (cvs) version id string and (cvs) tag name.
  66 !
  67 !  error_mesg          Print notes, warnings and error messages,
  68 !                      terminates program for error messages.
  69 !                      (use error levels NOTE,WARNING,FATAL)
  70 !
  71 !  open_namelist_file  Opens namelist file for reading only.
  72 !
  73 !  open_restart_file   Opens a file that will be used for reading or writing
  74 !                      restart files with native unformatted data.
  75 !
  76 !  open_ieee32_file    Opens a file that will be used for reading or writing
  77 !                      unformatted 32-bit ieee data.
  78 !
  79 !  close_file          Closes a file that was opened using
  80 !                      open_namelist_file, open_restart_file, or
  81 !                      open_ieee32_file.
  82 !
  83 !  set_domain          Call this routine to internally store in fms_mod the
  84 !                      domain2d data type prior to calling the distributed
  85 !                      data I/O routines read_data and write_data.
  86 !
  87 !  read_data           Reads distributed data from a single threaded file.
  88 !
  89 !  write_data          Writes distributed data to a single threaded file.
  90 !
  91 !  fms_init            Initializes the fms module and also the
  92 !                      mpp_io module (which initializes all mpp mods).
  93 !                      Will be called automatically if the user does
  94 !                      not call it.
  95 !
  96 !  fms_end             Calls mpp exit routines.
  97 !
  98 !  lowercase           Convert character strings to all lower case
  99 !
 100 !  uppercase           Convert character strings to all upper case
 101 !
 102 !  monotonic_array     Determines if the real input array has
 103 !                      monotonically increasing or decreasing values.
 104 !
 105 !  string_array_index  Match the input character string to a string
 106 !                      in an array/list of character strings.
 107 !
 108 !-----------------------------------------------------------------------
 109 !---- published routines from mpp_mod ----
 110 !
 111 !   mpp_error, NOTE, WARNING, FATAL
 112 !   mpp_error_state
 113 !   mpp_pe, mpp_npes, mpp_root_pe
 114 !   stdin, stdout, stderr, stdlog
 115 !   mpp_chksum
 116 !
 117 !   mpp_clock_id, mpp_clock_begin , mpp_clock_end
 118 !   MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED
 119 !   CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER,
 120 !   CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
 121 !
 122 !-----------------------------------------------------------------------
 123
 124 use          mpp_mod, only:  mpp_error, NOTE, WARNING, FATAL,    &
 125                              mpp_set_warn_level,                 &
 126                              mpp_transmit, ALL_PES,              &
 127                              mpp_pe, mpp_npes, mpp_root_pe,      &
 128                              mpp_sync, mpp_chksum,               &
 129                              mpp_clock_begin, mpp_clock_end,     &
 130                              mpp_clock_id, mpp_init, mpp_exit,   &
 131                              MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, &
 132                              CLOCK_COMPONENT, CLOCK_SUBCOMPONENT,&
 133                              CLOCK_MODULE_DRIVER, CLOCK_MODULE,  &
 134                              CLOCK_ROUTINE, CLOCK_LOOP,          &
 135                              CLOCK_INFRA, mpp_clock_set_grain,   &
 136                              mpp_set_stack_size,                 &
 137                              stdin, stdout, stderr, stdlog,      &
 138                              mpp_error_state, lowercase,         &
 139                              uppercase, mpp_broadcast, input_nml_file, &
 140                              get_unit, read_input_nml
 141
 142 use  mpp_domains_mod, only:  domain2D, mpp_define_domains, &
 143                              mpp_update_domains, GLOBAL_DATA_DOMAIN, &
 144                              mpp_domains_init, mpp_domains_exit,     &
 145                              mpp_global_field, mpp_domains_set_stack_size,  &
 146                              mpp_get_compute_domain, mpp_get_global_domain, &
 147                              mpp_get_data_domain
 148
 149 use       mpp_io_mod, only:  mpp_io_init, mpp_open, mpp_close,         &
 150                        MPP_ASCII, MPP_NATIVE, MPP_IEEE32, MPP_NETCDF,  &
 151                        MPP_RDONLY, MPP_WRONLY, MPP_APPEND, MPP_OVERWR, &
 152                        MPP_SEQUENTIAL, MPP_DIRECT,                     &
 153                        MPP_SINGLE, MPP_MULTI, MPP_DELETE, mpp_io_exit, &
 154                        fieldtype, mpp_get_atts, mpp_get_info, mpp_get_fields, &
 155                        do_cf_compliance
 156
 157 use fms_io_mod, only : fms_io_init, fms_io_exit, field_size, &
 158                        read_data, write_data, read_compressed, read_distributed, &
 159                        open_namelist_file, open_restart_file, open_ieee32_file, close_file, &
 160                        get_domain_decomp, &
 161                        open_file, open_direct_file, get_mosaic_tile_grid, &
 162                        get_mosaic_tile_file, get_global_att_value, file_exist, field_exist, &
 163                        set_domain, nullify_domain
 164 use fms2_io_mod, only: fms2_io_init
 165 use memutils_mod, only: print_memuse_stats, memutils_init
 166 use grid2_mod, only: grid_init, grid_end
 167
 168 use, intrinsic :: iso_c_binding
 169
 170 implicit none
 171 private
 172
 173 ! routines for initialization and termination of module
 174 public :: fms_init, fms_end
 175
 176 ! routines for opening/closing specific types of file
 177 public :: open_namelist_file, open_restart_file, &
 178           open_ieee32_file, close_file, &
 179           open_file, open_direct_file
 180
 181 ! routines for reading/writing distributed data
 182 public :: read_data, write_data, read_compressed, read_distributed
 183 public :: get_domain_decomp, field_size
 184 public :: get_global_att_value
 185
 186 ! routines for get mosaic information
 187 public :: get_mosaic_tile_grid, get_mosaic_tile_file
 188
 189 ! miscellaneous i/o routines
 190 public :: file_exist, check_nml_error, field_exist,     &
 191           error_mesg, fms_error_handler
 192 ! version logging routine (originally from fms_io)
 193 public :: write_version_number
 194
 195 ! miscellaneous utilities (non i/o)
 196 public :: lowercase, uppercase,        &
 197           string_array_index, monotonic_array, &
 198           set_domain, nullify_domain
 199
 200 ! public mpp interfaces
 201 public :: mpp_error, NOTE, WARNING, FATAL, &
 202           mpp_error_state,                 &
 203           mpp_pe, mpp_npes, mpp_root_pe,   &
 204           stdin, stdout, stderr, stdlog,   &
 205           mpp_chksum, get_unit, read_input_nml
 206 public :: input_nml_file
 207 public :: mpp_clock_id, mpp_clock_begin, mpp_clock_end
 208 public :: MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED
 209 public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, &
 210           CLOCK_MODULE_DRIVER, CLOCK_MODULE,   &
 211           CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
 212 public :: fms_c2f_string, fms_cstring2cpointer
 213 !public from the old fms_io but not exists here
 214 public :: string
 215
 216 ! public mpp-io interfaces
 217 public :: do_cf_compliance
 218
 219 !Balaji
 220 !this is published by fms and applied to any initialized clocks
 221 !of course you can go and set the flag to SYNC or DETAILED by hand
 222 integer, public :: clock_flag_default
 223 !> @}
 224   !> Namelist read error values
 225   !> @ingroup fms_mod
 226   TYPE nml_errors_type
 227      INTEGER :: multipleNMLSinFile
 228      INTEGER :: badType1
 229      INTEGER :: badType2
 230      INTEGER :: missingVar
 231      INTEGER :: NotInFile
 232   END TYPE nml_errors_type
 233   TYPE(nml_errors_type), SAVE :: nml_errors
 234 !> @addtogroup fms_mod
 235 !> @{
 236
 237 !------ namelist interface -------
 238 !------ adjustable severity level for warnings ------
 239
 240   logical           :: read_all_pe   = .true. !< Read global data on all processors extracting local
 241                        !! part needed (TRUE) or read global data on PE0 and broadcast to all
 242                        !! PEs(FALSE).
 243   character(len=16) :: clock_grain = 'NONE' !< The level of clock granularity used for performance
 244                        !! timing sections of code. Possible values in order of increasing detail
 245                        !! are: 'NONE', 'COMPONENT', 'SUBCOMPONENT', 'MODULE_DRIVER', 'MODULE',
 246                        !! 'ROUTINE', 'LOOP', and 'INFRA'.  Code sections are defined using routines
 247                        !! in MPP module: mpp_clock_id, mpp_clock_begin, and mpp_clock_end. The fms
 248                        !! module makes these routines public. A list of timed code sections will be
 249                        !! printed to STDOUT. See the @ref mpp_mod module for more details.
 250   character(len=16) :: clock_flags='NONE' !< Possible values are 'NONE', 'SYNC', or 'DETAILED'.
 251                        !! SYNC will give accurate information on load balance of the clocked
 252                        !! portion of code. DETAILED also turns on detailed message-passing
 253                        !! performance diagnosis. Both SYNC and DETAILED will  work correctly on
 254                        !! innermost clock nest and distort outer clocks, and possibly the overall
 255                        !! code time. See the @ref mpp_mod module for more details.
 256   character(len=8)  :: warning_level = 'warning' !< Sets the termination condition for the WARNING
 257                        !! flag to interfaces error_mesg/mpp_error. set warning_level = 'fatal'
 258                        !! (program crashes for warning messages) or 'warning' (prints warning
 259                        !! message and continues).
 260   integer           :: stack_size = 0 !< The size in words of the MPP user stack. If stack_size > 0,
 261                        !! the following MPP routine is called: call mpp_set_stack_size (stack_size).
 262                        !! If stack_size = 0 (default) then the default size set by mpp_mod is used.
 263   integer           :: domains_stack_size = 0 !< The size in words of the MPP_DOMAINS user stack. If
 264                        !! domains_stack_size > 0, the following MPP_DOMAINS routine is called:
 265                        !! call mpp_domains_set_stack_size (domains_stack_size). If
 266                        !! domains_stack_size = 0 (default) then the default size set by
 267                        !! @ref mpp_domains_mod is used.
 268   logical, public   :: print_memory_usage = .FALSE. !< If set to .TRUE., memory usage statistics
 269                        !! will be printed at various points in the code. It is used to study memory
 270                        !! usage, e.g to detect memory leaks.
 271
 272 !------ namelist interface -------
 273
 274   namelist /fms_nml/  read_all_pe, clock_grain, clock_flags,         &
 275                       warning_level, stack_size, domains_stack_size, &
 276                       print_memory_usage
 277
 278 !   ---- private data for check_nml_error ----
 279
 280    integer, private :: num_nml_error_codes, nml_error_codes(20)
 281    logical, private :: do_nml_error_init = .true.
 282    private  nml_error_init
 283
 284
 285 !  ---- version number -----
 286
 287 ! Include variable "version" to be written to log file.
 288 #include<file_version.h>
 289
 290   logical :: module_is_initialized = .FALSE.
 291
 292   logical, private :: fms_io_initialized = .FALSE.!> used to make sure fms_io version is only
 293                                                   !! written to log once
 294
 295 !> @}
 296
 297 !> Converts a number to a string
 298 !> @ingroup fms_mod
 299 interface string
 300    module procedure string_from_integer
 301    module procedure string_from_real
 302 end interface
 303 !> Converts a C string to a Fortran string
 304 !> @ingroup fms_mod
 305 interface fms_c2f_string
 306    module procedure cstring_fortran_conversion
 307    module procedure cpointer_fortran_conversion
 308 end interface
 309 !> C functions
 310   interface
 311     !> @brief converts a kind=c_char to type c_ptr
 312     pure function fms_cstring2cpointer (cs) result (cp) bind(c, name="cstring2cpointer")
 313       import c_char, c_ptr
 314         character(kind=c_char), intent(in) :: cs(*) !< C string input
 315         type (c_ptr) :: cp !< C pointer
 316     end function fms_cstring2cpointer
 317
 318     !> @brief Finds the length of a C-string
 319     integer(c_size_t) pure function c_strlen(s) bind(c,name="strlen")
 320       import c_size_t, c_ptr
 321       type(c_ptr), intent(in), value :: s !< A C-string whose size is desired
 322     end function
 323
 324     !> @brief Frees a C pointer
 325     subroutine c_free(ptr) bind(c,name="free")
 326       import c_ptr
 327       type(c_ptr), value :: ptr !< A C-pointer to free
 328     end subroutine
 329   end interface
 330
 331 !> @addtogroup fms_mod
 332 !> @{
 333 contains
 334
 335 !#######################################################################
 336
 337 !> @brief Initializes the FMS module and also calls the initialization routines for all
 338 !!     modules in the MPP package. Will be called automatically if the user does
 339 !!     not call it.
 340 !! @details Initialization routine for the fms module. It also calls initialization routines
 341 !!      for the mpp, mpp_domains, and mpp_io modules. Although this routine
 342 !!      will be called automatically by other fms_mod routines, users should
 343 !!      explicitly call fms_init. If this routine is called more than once it will
 344 !!      return silently. There are no arguments.
 345 !!
 346 !> @throws FATAL, invalid entry for namelist variable warning_level
 347 !! The namelist variable warning_level must be either 'fatal' or 'warning'(case-insensitive)
 348 !!
 349 !> @throws FATAL, invalid entry for namelist variable clock_grain
 350 !! The namelist variable clock_grain must be one of the following values:
 351 !! 'NONE', 'COMPONENT', 'SUBCOMPONENT', 'MODULE_DRIVER', 'MODULE', 'ROUTINE',
 352 !! 'LOOP', or 'INFRA' (case-insensitive).
 353 subroutine fms_init (localcomm, alt_input_nml_path)
 354
 355 !--- needed to output the version number of constants_mod to the logfile ---
 356  use constants_mod, only: constants_version=>version !pjp: PI not computed
 357  use fms_io_mod,    only: fms_io_version
 358
 359  integer, intent(in), optional :: localcomm
 360  character(len=*), intent(in), optional :: alt_input_nml_path
 361  integer :: ierr, io
 362  integer :: logunitnum
 363  integer :: stdout_unit !< Unit number for the stdout file
 364
 365     if (module_is_initialized) return    ! return silently if already called
 366     module_is_initialized = .true.
 367 !---- initialize mpp routines ----
 368     if(present(localcomm)) then
 369        if(present(alt_input_nml_path)) then
 370           call mpp_init(localcomm=localcomm, alt_input_nml_path=alt_input_nml_path)
 371        else
 372           call mpp_init(localcomm=localcomm)
 373        endif
 374     else
 375        if(present(alt_input_nml_path)) then
 376           call mpp_init(alt_input_nml_path=alt_input_nml_path)
 377        else
 378           call mpp_init()
 379        endif
 380     endif
 381     call mpp_domains_init()
 382     call fms_io_init()
 383     !! write_version_number is inaccesible from fms_io_mod so write it from here if not written
 384     if(.not.fms_io_initialized) then
 385       call write_version_number("FMS_IO_MOD", fms_io_version)
 386       fms_io_initialized = .true.
 387     endif
 388     call fms2_io_init()
 389     logunitnum = stdlog()
 390 !---- read namelist input ----
 391
 392     call nml_error_init()  ! first initialize namelist iostat error codes
 393
 394     read (input_nml_file, fms_nml, iostat=io)
 395     ierr = check_nml_error(io,'fms_nml')
 396
 397 !---- define mpp stack sizes if non-zero -----
 398
 399     if (        stack_size > 0) call         mpp_set_stack_size (        stack_size)
 400     if (domains_stack_size > 0) call mpp_domains_set_stack_size (domains_stack_size)
 401
 402 !---- set severity level for warnings ----
 403
 404     select case( trim(lowercase(warning_level)) )
 405     case( 'fatal' )
 406         call mpp_set_warn_level ( FATAL )
 407     case( 'warning' )
 408         call mpp_set_warn_level ( WARNING )
 409     case default
 410         call error_mesg ( 'fms_init',  &
 411              'invalid entry for namelist variable warning_level', FATAL )
 412     end select
 413
 414 !--- set granularity for timing code sections ---
 415
 416     select case( trim(uppercase(clock_grain)) )
 417     case( 'NONE' )
 418         call mpp_clock_set_grain (0)
 419     case( 'COMPONENT' )
 420         call mpp_clock_set_grain (CLOCK_COMPONENT)
 421     case( 'SUBCOMPONENT' )
 422         call mpp_clock_set_grain (CLOCK_SUBCOMPONENT)
 423     case( 'MODULE_DRIVER' )
 424         call mpp_clock_set_grain (CLOCK_MODULE_DRIVER)
 425     case( 'MODULE' )
 426         call mpp_clock_set_grain (CLOCK_MODULE)
 427     case( 'ROUTINE' )
 428         call mpp_clock_set_grain (CLOCK_ROUTINE)
 429     case( 'LOOP' )
 430         call mpp_clock_set_grain (CLOCK_LOOP)
 431     case( 'INFRA' )
 432         call mpp_clock_set_grain (CLOCK_INFRA)
 433     case default
 434         call error_mesg ( 'fms_init',  &
 435              'invalid entry for namelist variable clock_grain', FATAL )
 436     end select
 437 !Balaji
 438     select case( trim(uppercase(clock_flags)) )
 439     case( 'NONE' )
 440        clock_flag_default = 0
 441     case( 'SYNC' )
 442        clock_flag_default = MPP_CLOCK_SYNC
 443     case( 'DETAILED' )
 444        clock_flag_default = MPP_CLOCK_DETAILED
 445     case default
 446        call error_mesg ( 'fms_init',  &
 447             'invalid entry for namelist variable clock_flags', FATAL )
 448    end select
 449
 450 !--- write version info and namelist to logfile ---
 451
 452     call write_version_number("FMS_MOD", version)
 453     if (mpp_pe() == mpp_root_pe()) then
 454       stdout_unit = stdlog()
 455       write (stdout_unit, nml=fms_nml)
 456       write (stdout_unit,*) 'nml_error_codes=', nml_error_codes(1:num_nml_error_codes)
 457     endif
 458
 459     call memutils_init( print_memory_usage )
 460     call print_memuse_stats('fms_init')
 461
 462 !--- output version information constants to the logfile
 463     call write_version_number("CONSTANTS_MOD", constants_version)
 464     call grid_init
 465
 466 end subroutine fms_init
 467
 468 !#######################################################################
 469
 470 !> @brief Calls the termination routines for all modules in the MPP package.
 471 !!
 472 !> Termination routine for the fms module. It also calls destructor routines
 473 !! for the mpp, mpp_domains, and mpp_io modules. If this routine is called
 474 !! more than once it will return silently. There are no arguments.
 475 subroutine fms_end ( )
 476
 477     if (.not.module_is_initialized) return  ! return silently
 478 !    call fms_io_exit  ! now called from coupler_end
 479     call grid_end
 480     call mpp_io_exit
 481     call mpp_domains_exit
 482     call mpp_exit
 483     module_is_initialized =.FALSE.
 484
 485 end subroutine fms_end
 486
 487 !#######################################################################
 488
 489  !> @brief Print notes, warnings and error messages; terminates program for warning
 490  !! and error messages. Usage of @ref mpp_error is preferable. (use error levels NOTE,WARNING,FATAL, see example below)
 491  !! @details Print notes, warnings and error messages; and terminates the program for
 492  !!     error messages. This routine is a wrapper around mpp_error, and is provided
 493  !!     for backward compatibility. This module also publishes mpp_error,
 494  !!      <B>users should try to use the mpp_error interface</B>.
 495  !!
 496  !! <br>Example usage:
 497  !! @code{.F90}
 498  !! use fms_mod, only: error_mesg, FATAL, NOTE
 499  !! call error_mesg ('fms_mod', 'initialization not called', FATAL)
 500  !! call error_mesg ('fms_mod', 'fms_mod message', NOTE)
 501  !! @endcode
 502  subroutine error_mesg (routine, message, level)
 503   character(len=*), intent(in) :: routine !< Routine name where the warning or error has occurred.
 504   character(len=*), intent(in) :: message !< Warning or error message to be printed.
 505   integer,          intent(in) :: level !< Level of severity; set to NOTE, WARNING, or FATAL Termination always occurs
 506                                         !! for FATAL, never for NOTE, and is settable for WARNING (see namelist).
 507
 508 !  input:
 509 !      routine   name of the calling routine (character string)
 510 !      message   message written to output   (character string)
 511 !      level     set to NOTE, MESSAGE, or FATAL (integer)
 512
 513     if (.not.module_is_initialized) call fms_init ( )
 514     call mpp_error ( routine, message, level )
 515
 516  end subroutine error_mesg
 517
 518 !#######################################################################
 519
 520  !> @brief Facilitates the control of fatal error conditions
 521  !! @details When err_msg is present, message is copied into err_msg
 522  !!     and the function returns a value of .true.
 523  !!     Otherwise calls mpp_error to terminate execution.
 524  !!     The intended use is as shown below.
 525  !! @returns true when err_msg is present
 526  !! @code{.F90}
 527  !! if(fms_error_handler(routine, message, err_msg)) return
 528  !! @endcode
 529  function fms_error_handler(routine, message, err_msg)
 530
 531  logical :: fms_error_handler
 532  character(len=*), intent(in) :: routine !< Routine name where the fatal error has occurred.
 533  character(len=*), intent(in) :: message !< fatal error message to be printed.
 534  character(len=*), intent(out), optional :: err_msg !< When err_msg is present: err_msg = message
 535
 536  fms_error_handler = .false.
 537  if(present(err_msg)) then
 538    err_msg = message
 539    fms_error_handler = .true.
 540  else
 541    call mpp_error(trim(routine),trim(message),FATAL)
 542  endif
 543
 544  end function fms_error_handler
 545
 546 ! used to check the iostat argument that is
 547 ! returned after reading a namelist
 548 ! see the online documentation for how this routine might be used
 549
 550   !> @brief Checks the iostat argument that is returned after reading a namelist
 551   !!     and determines if the error code is valid.
 552   !! @return This function returns the input iostat value (integer) if it is an
 553   !!     allowable error code. If the iostat error code is not
 554   !!     allowable, an error message is printed and the program terminated.
 555   !! @details The FMS allows multiple namelist records to reside in the same file.
 556   !!     Use this interface to check the iostat argument that is returned after
 557   !!     reading a record from the namelist file. If an invalid iostat value
 558   !!     is detected this routine will produce a fatal error. See the NOTE below.
 559   !!
 560   !!     Some compilers will return non-zero iostat values when reading through
 561   !!     files with multiple namelist. This routine
 562   !!     will try skip these errors and only terminate for true namelist errors.
 563   !!
 564   !!     <br>Examples<br>
 565   !!
 566   !!       The following example checks if a file exists, reads a namelist input
 567   !!       from that file, and checks for errors in that
 568   !!       namelist. When the correct namelist is read and it has no errors the
 569   !!       routine check_nml_error will return zero and the while loop will exit.
 570   !!       This code segment should be used to read namelist files.
 571   !!       @code{.F90}
 572   !!         integer :: ierr, io
 573   !!
 574   !!         read (input_nml_file, fms_nml, iostat=io)
 575   !!         ierr = check_nml_error(io,'fms_nml')
 576   !!       @endcode
 577   !! @throws FATAL, Unknown error while reading namelist ...., (IOSTAT = ####)
 578   !! There was an error reading the namelist specified. Carefully examine all namelist and variables
 579   !! for anything incorrect (e.g. malformed, hidden characters).
 580   !!
 581   !! @throws FATAL, Unknown namelist, or mistyped namelist variable in namelist ...., (IOSTAT = ####)
 582   !! The name list given doesn't exist in the namelist file, or a variable in the namelist is
 583   !! mistyped or isn't a namelist variable.
 584   INTEGER FUNCTION check_nml_error(IOSTAT, NML_NAME)
 585     INTEGER, INTENT(in) :: IOSTAT !< The iostat value returned when reading a namelist record.
 586     CHARACTER(len=*), INTENT(in) :: NML_NAME !< The name of the namelist. This name will be printed if an error is
 587                                              !! encountered, otherwise the name is not used.
 588
 589     CHARACTER(len=256) :: err_str
 590
 591     IF ( .NOT.module_is_initialized) CALL fms_init()
 592
 593     check_nml_error = IOSTAT
 594
 595     ! Return on valid IOSTAT values
 596     IF ( IOSTAT <= 0 .OR.&
 597        & IOSTAT == nml_errors%multipleNMLSinFile .OR.&
 598        & IOSTAT == nml_errors%NotInFile) RETURN
 599
 600     ! Everything else is a FATAL
 601     IF ( (IOSTAT == nml_errors%badType1 .OR. IOSTAT == nml_errors%badType2) .OR. IOSTAT == nml_errors%missingVar ) THEN
 602        WRITE (err_str,*) 'Unknown namelist, or mistyped namelist variable in namelist ',TRIM(NML_NAME),', &
 603              &  (IOSTAT = ',IOSTAT,')'
 604        CALL error_mesg ('check_nml_error in fms_mod', err_str, FATAL)
 605        CALL mpp_sync()
 606     ELSE
 607        WRITE (err_str,*) 'Unknown error while reading namelist ',TRIM(NML_NAME),', (IOSTAT = ',IOSTAT,')'
 608        CALL error_mesg ('check_nml_error in fms_mod', err_str, FATAL)
 609        CALL mpp_sync()
 610     END IF
 611   END FUNCTION check_nml_error
 612
 613 !-----------------------------------------------------------------------
 614 !   private routine for initializing allowable error codes
 615
 616   !> @brief Determines the IOSTAT error value for some common Namelist errors.
 617   !!   Also checks if the compiler returns a non-zero status if there are
 618   !!   multiple namelist records in a single file.
 619   SUBROUTINE nml_error_init
 620     ! Determines the IOSTAT error value for some common Namelist errors.
 621     ! Also checks if the compiler returns a non-zero status if there are
 622     ! multiple namelist records in a single file.
 623     INTEGER, PARAMETER :: unit_begin = 20, unit_end = 1024
 624     INTEGER :: fileunit, io_stat
 625     INTEGER, DIMENSION(5) :: nml_iostats
 626     LOGICAL :: opened
 627
 628     ! Variables for sample namelists
 629     INTEGER :: i1 !< Variables for sample namelists
 630     INTEGER :: i2 !< Variables for sample namelists
 631     REAL :: r1, r2
 632     LOGICAL :: l1
 633     NAMELIST /a_nml/ i1, r1
 634     NAMELIST /b_nml/ i2, r2, l1
 635     NAMELIST /badType1_nml/ i1, r1
 636     NAMELIST /badType2_nml/ i1, r1
 637     NAMELIST /missingVar_nml/ i2, r2
 638     NAMELIST /not_in_file_nml/ i2, r2
 639
 640     ! Initialize the sample namelist variables
 641     i1 = 1
 642     i2 = 2
 643     r1 = 1.0
 644     r2 = 2.0
 645     l1 = .FALSE.
 646
 647     ! Create a dummy namelist file
 648     IF ( mpp_pe() == mpp_root_pe() ) THEN
 649        ! Find a free file unit for a scratch file
 650        file_opened: DO fileunit = unit_begin, unit_end
 651           INQUIRE(UNIT=fileunit, OPENED=opened)
 652           IF ( .NOT.opened ) EXIT file_opened
 653        END DO file_opened
 654
 655 #if defined(__PGI) || defined(_CRAYFTN)
 656        OPEN (UNIT=fileunit, FILE='_read_error.nml', IOSTAT=io_stat)
 657 #else
 658        OPEN (UNIT=fileunit, STATUS='SCRATCH', IOSTAT=io_stat)
 659 #endif
 660
 661        ! Write sample namelist to the SCRATCH file.
 662        WRITE (UNIT=fileunit, NML=a_nml, IOSTAT=io_stat)
 663        WRITE (UNIT=fileunit, NML=b_nml, IOSTAT=io_stat)
 664        WRITE (UNIT=fileunit, IOSTAT=io_stat, FMT='(/,"&badType1_nml  i1=1, r1=''bad'' /",/)')
 665        WRITE (UNIT=fileunit, IOSTAT=io_stat, FMT='(/,"&badType2_nml  i1=1, r1=.true. /",/)')
 666        WRITE (UNIT=fileunit, IOSTAT=io_stat, FMT='(/,"&missingVar_nml  i2=1, r2=1.0e0, l1=.true. /",/)')
 667
 668        ! Rewind for reading
 669        REWIND(UNIT=fileunit)
 670
 671        ! Read the second namelist from the file -- check for namelist bug
 672        READ (UNIT=fileunit, NML=b_nml, IOSTAT=nml_iostats(1))
 673        REWIND(UNIT=fileunit)
 674
 675        ! Read in bad type 1 --- Some compilers treat the string cast differently
 676        READ (UNIT=fileunit, NML=badType1_nml, IOSTAT=nml_iostats(2))
 677        REWIND(UNIT=fileunit)
 678
 679        ! Read in bad type 2
 680        READ (UNIT=fileunit, NML=badType2_nml, IOSTAT=nml_iostats(3))
 681        REWIND(UNIT=fileunit)
 682
 683        ! Read in missing variable/misstyped
 684        READ (UNIT=fileunit, NML=missingVar_nml, IOSTAT=nml_iostats(4))
 685        REWIND(UNIT=fileunit)
 686
 687        ! Code for namelist not in file
 688        READ (UNIT=fileunit, NML=not_in_file_nml, IOSTAT=nml_iostats(5))
 689
 690        ! Done, close file
 691        CLOSE (UNIT=fileunit)
 692
 693        ! Some compilers don't handle the type casting as well as we would like.
 694        IF ( nml_iostats(2) * nml_iostats(3) .EQ. 0 ) THEN
 695           IF ( nml_iostats(2) .NE. 0 .AND. nml_iostats(3) .EQ. 0 ) THEN
 696              nml_iostats(3) = nml_iostats(2)
 697           ELSE IF ( nml_iostats(2) .EQ. 0 .AND. nml_iostats(3) .NE.0 ) THEN
 698              nml_iostats(2) = nml_iostats(3)
 699           ELSE
 700              nml_iostats(2) = nml_iostats(4)
 701              nml_iostats(2) = nml_iostats(4)
 702           END IF
 703        END IF
 704     END IF
 705
 706     ! Broadcast nml_errors
 707     CALL mpp_broadcast(nml_iostats,5,mpp_root_pe())
 708     nml_errors%multipleNMLSinFile = nml_iostats(1)
 709     nml_errors%badType1 = nml_iostats(2)
 710     nml_errors%badType2 = nml_iostats(3)
 711     nml_errors%missingVar = nml_iostats(4)
 712     nml_errors%NotInFile = nml_iostats(5)
 713
 714     do_nml_error_init = .FALSE.
 715   END SUBROUTINE nml_error_init
 716
 717 !#######################################################################
 718
 719 !> @brief match the input character string to a string
 720 !!     in an array/list of character strings
 721 !! @return If an exact match was found then true is returned, otherwise false is returned.
 722 !! @details Tries to find a match for a character string in a list of character strings.
 723 !!      The match is case sensitive and disregards blank characters to the right of
 724 !!      the string.
 725 !!
 726 !!      <br>Examples<br>
 727 !!      @code{.F90}
 728 !!       string = "def"
 729 !!       string_array = (/ "abcd", "def ", "fghi" /)
 730 !!
 731 !!       string_array_index ( string, string_array, index )
 732 !!      @endcode
 733 !!       Returns: TRUE, index = 2
 734 function string_array_index ( string, string_array, index ) result (found)
 735 character(len=*),  intent(in)  :: string !< Character string of arbitrary length.
 736 character(len=*),  intent(in)  :: string_array(:) !< Array/list of character strings.
 737 integer, optional, intent(out) :: index !< The index of string_array where the first match was found. If
 738                                         !! no match was found then index = 0.
 739 logical :: found !< If an exact match was found then TRUE is returned, otherwise FALSE is returned.
 740 integer :: i
 741
 742 ! initialize this function to false
 743 ! loop thru string_array and exit when a match is found
 744
 745   found = .false.
 746   if (present(index)) index = 0
 747
 748   do i = 1, size(string_array(:))
 749     ! found a string match ?
 750     if ( trim(string) == trim(string_array(i)) ) then
 751          found = .true.
 752          if (present(index)) index = i
 753          exit
 754     endif
 755   enddo
 756
 757 end function string_array_index
 758
 759 !#######################################################################
 760
 761 !> @brief Determines if a real input array has monotonically increasing or
 762 !!     decreasing values.
 763 !! @return If the input array of real values either increases or decreases monotonically then true
 764 !! is returned, otherwise false is returned.
 765 function monotonic_array ( array, direction )
 766 real,    intent(in)            :: array(:) !< An array of real values. If the size(array) < 2 this function
 767                                            !! assumes the array is not monotonic, no fatal error will occur.
 768 integer, intent(out), optional :: direction !< If the input array is:
 769                                             !! >> monotonic (small to large) then direction = +1.
 770                                             !! >> monotonic (large to small) then direction = -1.
 771                                             !! >> not monotonic then direction = 0.
 772 logical :: monotonic_array !< If the input array of real values either increases or decreases monotonically
 773                            !! then TRUE is returned, otherwise FALSE is returned.
 774 integer :: i
 775
 776 ! initialize
 777   monotonic_array = .false.
 778   if (present(direction)) direction = 0
 779
 780 ! array too short
 781   if ( size(array(:)) < 2 ) return
 782
 783 ! ascending
 784   if ( array(1) < array(size(array(:))) ) then
 785      do i = 2, size(array(:))
 786        if (array(i-1) < array(i)) cycle
 787        return
 788      enddo
 789      monotonic_array = .true.
 790      if (present(direction)) direction = +1
 791
 792 ! descending
 793   else
 794      do i = 2, size(array(:))
 795        if (array(i-1) > array(i)) cycle
 796        return
 797      enddo
 798      monotonic_array = .true.
 799      if (present(direction)) direction = -1
 800   endif
 801
 802 end function monotonic_array
 803
 804 !! Functions from the old fms_io
 805   !> @brief Converts an integer to a string
 806   !!
 807   !> This has been updated from the fms_io function.
 808   function string_from_integer(i) result (res)
 809     integer, intent(in) :: i !< Integer to be converted to a string
 810     character(:),allocatable :: res !< String converted frominteger
 811     character(range(i)+2) :: tmp !< Temp string that is set to correct size
 812     write(tmp,'(i0)') i
 813     res = trim(tmp)
 814    return
 815
 816   end function string_from_integer
 817
 818   !#######################################################################
 819   !> @brief Converts a real to a string
 820   function string_from_real(a)
 821     real, intent(in) :: a
 822     character(len=32) :: string_from_real
 823
 824     write(string_from_real,*) a
 825
 826     return
 827
 828   end function string_from_real
 829
 830 !> \brief Converts a C-string to a pointer and then to a Fortran string
 831 function cstring_fortran_conversion (cstring) result(fstring)
 832  character (kind=c_char), intent(in) :: cstring (*) !< Input C-string
 833  character(len=:), allocatable :: fstring    !< The fortran string returned
 834  fstring = cpointer_fortran_conversion(fms_cstring2cpointer(cstring))
 835 end function cstring_fortran_conversion
 836
 837 !> \brief Converts a C-string returned from a TYPE(C_PTR) function to
 838 !! a fortran string with type character.
 839 function cpointer_fortran_conversion (cstring) result(fstring)
 840  type (c_ptr), intent(in) :: cstring !< Input C-pointer
 841  character(len=:), allocatable :: fstring    !< The fortran string returned
 842  character(len=:,kind=c_char), pointer :: string_buffer !< A temporary pointer to between C and Fortran
 843  integer(c_size_t) :: length !< The string length
 844
 845   length = c_strlen(cstring)
 846   allocate (character(len=length, kind=c_char) :: string_buffer)
 847     block
 848       character(len=length,kind=c_char), pointer :: s
 849       call c_f_pointer(cstring,s)  ! Recovers a view of the C string
 850       string_buffer = s                   ! Copies the string contents
 851     end block
 852
 853  allocate(character(len=length) :: fstring) !> Set the length of fstring
 854 fstring = string_buffer
 855  deallocate(string_buffer)
 856
 857 end function cpointer_fortran_conversion
 858
 859 !#######################################################################
 860 !> @brief Prints to the log file (or a specified unit) the version id string and
 861 !!  tag name.
 862 subroutine write_version_number (version, tag, unit)
 863   character(len=*), intent(in) :: version !> string that contains routine name
 864   character(len=*), intent(in), optional :: tag !> tag name that code was checked out with
 865   integer,          intent(in), optional :: unit !> alternate unit number to direct output,
 866                                                  !! defaults to stdlog
 867   integer :: logunit
 868
 869   if (.not.module_is_initialized) call fms_init ( )
 870
 871   logunit = stdlog()
 872
 873   if (present(unit)) then
 874     logunit = unit
 875   else
 876     ! only allow stdlog messages on root pe
 877     if ( mpp_pe() /= mpp_root_pe() ) return
 878   endif
 879
 880   if (present(tag)) then
 881     write (logunit,'(/,80("="),/(a))') trim(version), trim(tag)
 882   else
 883     write (logunit,'(/,80("="),/(a))') trim(version)
 884   endif
 885
 886 end subroutine write_version_number
 887
 888 end module fms_mod
 889 ! <INFO>
 890 !   <BUG>
 891 !     Namelist error checking may not work correctly with some compilers.
 892 !
 893 !     Users should beware when mixing Fortran reads and read_data calls. If a
 894 !     Fortran read follows read_data and namelist variable read_all_pe = FALSE
 895 !     (not the default), then the code will fail. It is safest if Fortran reads
 896 !     precede calls to read_data.
 897 !   </BUG>
 898 !   <ERROR MSG="unexpected EOF" STATUS="FATAL">
 899 !     An unexpected end-of-file was encountered in a read_data call.
 900 !     You may want to use the optional end argument to detect the EOF.
 901 !   </ERROR>
 902 !   <NOTE>
 903 !     1) If the <B>MPP</B> or <B>MPP_DOMAINS</B> stack size is exceeded the
 904 !     program will terminate after printing the required size.
 905 !
 906 !     2) When running on a very small number of processors or for high
 907 !     resolution models the default domains_stack_size will
 908 !     probably be insufficient.
 909 !
 910 !     3) The following performance routines in the <B>MPP</B> module are published by this module.
 911 !<PRE>
 912 !        mpp_clock_id, mpp_clock_begin, mpp_clock_end
 913 !</PRE>
 914 !        and associated parameters that are published:
 915 !<PRE>
 916 !        MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, CLOCK_COMPONENT, CLOCK_SUBCOMPONENT,
 917 !        CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
 918 !</PRE>
 919 !
 920 !     4) Here is an example of how to time a section of code.<BR/>
 921 !<PRE>
 922 !          use fms_mod, only: mpp_clock_id, mpp_clock_begin, &
 923 !                             mpp_clock_end. MPP_CLOCK_SYNC, &
 924 !                             CLOCK_MODULE_DRIVER
 925 !          integer :: id_mycode
 926 !
 927 !          id_mycode = mpp_clock_id ('mycode loop', flags=MPP_CLOCK_SYNC, grain=CLOCK_MODULE_DRIVER)
 928 !          call mpp_clock_begin (id_mycode)
 929 !                        :
 930 !                        :
 931 !           ~~ this code will be timed ~~
 932 !                        :
 933 !                        :
 934 !          call mpp_clock_end (id_mycode)
 935 ! </PRE>
 936 !        Note: <TT>CLOCK_MODULE_DRIVER</TT> can be replaced with
 937 !        CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE,
 938 !        CLOCK_LOOP, or CLOCK_INFRA.
 939 !
 940 !   </NOTE>
 941 !   <FUTURE>
 942 !     NetCDF facilities for reading and writing restart files and (IEEE32)
 943 !       data files.
 944 !    </FUTURE>
 945 !    <FUTURE>
 946 !     May possible split the FMS module into two modules.
 947 !
 948 !      i.general utilities (FMS_MOD) <BR/>
 949 !     ii.I/O utilities (FMS_IO_MOD)
 950 !    </FUTURE>
 951 ! </INFO>
 952 !> @}
 953 ! close documentation grouping