FMS  2025.04
Flexible Modeling System
fms.F90
1 !***********************************************************************
2 !* Apache License 2.0
3 !*
4 !* This file is part of the GFDL Flexible Modeling System (FMS).
5 !*
6 !* Licensed under the Apache License, Version 2.0 (the "License");
7 !* you may not use this file except in compliance with the License.
8 !* You may obtain a copy of the License at
9 !*
10 !* http://www.apache.org/licenses/LICENSE-2.0
11 !*
12 !* FMS is distributed in the hope that it will be useful, but WITHOUT
13 !* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied;
14 !* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
15 !* PARTICULAR PURPOSE. See the License for the specific language
16 !* governing permissions and limitations under the License.
17 !***********************************************************************
18 !> @defgroup fms_mod fms_mod
19 !> @ingroup fms
20 !! @brief The fms module provides routines that are commonly used
21 !! by most FMS modules.
22 !> @author Bruce Wyman
23 !!
24 !> Here is a summary of the functions performed by routines
25 !! in the fms module.
26 !!
27 !! 1. Output module version numbers to a common (<TT>log</TT>) file
28 !! using a common format.<BR/>
29 !! 2. Open specific types of files common to many FMS modules.
30 !! These include namelist files, restart files, and 32-bit IEEE
31 !! data files. There also is a matching interface to close the files.
32 !! If other file types are needed the <TT>mpp_open</TT> and <TT>mpp_close</TT>
33 !! interfaces in module @ref mpp_io_mod must be used.<BR/>
34 !! 3. Read and write distributed data to simple native unformatted files.
35 !! This type of file (called a restart file) is used to checkpoint
36 !! model integrations for a subsequent restart of the run.<BR/>
37 !! 4. For convenience there are several routines published from
38 !! the @ref mpp module. These are routines for getting processor
39 !! numbers, commonly used I/O unit numbers, error handling, and timing sections of code.
40 
41 !> @addtogroup fms_mod
42 !> @{
43 module fms_mod
44 
45 !-----------------------------------------------------------------------
46 !
47 ! A collection of commonly used routines.
48 !
49 ! The routines are primarily I/O related, however, there also
50 ! exists several simple miscellaneous utility routines.
51 !
52 !-----------------------------------------------------------------------
53 !
54 ! file_exist Checks the existence of the given file name.
55 !
56 ! check_nml_error Checks the iostat argument that is returned after
57 ! reading a namelist and determines if the error
58 ! code is valid.
59 !
60 ! write_version_number Prints to the log file (or a specified unit)
61 ! the (cvs) version id string and (cvs) tag name.
62 !
63 ! error_mesg Print notes, warnings and error messages,
64 ! terminates program for error messages.
65 ! (use error levels NOTE,WARNING,FATAL)
66 !
67 ! open_namelist_file Opens namelist file for reading only.
68 !
69 ! open_restart_file Opens a file that will be used for reading or writing
70 ! restart files with native unformatted data.
71 !
72 ! open_ieee32_file Opens a file that will be used for reading or writing
73 ! unformatted 32-bit ieee data.
74 !
75 ! close_file Closes a file that was opened using
76 ! open_namelist_file, open_restart_file, or
77 ! open_ieee32_file.
78 !
79 ! set_domain Call this routine to internally store in fms_mod the
80 ! domain2d data type prior to calling the distributed
81 ! data I/O routines read_data and write_data.
82 !
83 ! read_data Reads distributed data from a single threaded file.
84 !
85 ! write_data Writes distributed data to a single threaded file.
86 !
87 ! fms_init Initializes the fms module and also the
88 ! mpp_io module (which initializes all mpp mods).
89 ! Will be called automatically if the user does
90 ! not call it.
91 !
92 ! fms_end Calls mpp exit routines.
93 !
94 ! lowercase Convert character strings to all lower case
95 !
96 ! uppercase Convert character strings to all upper case
97 !
98 ! monotonic_array Determines if the real input array has strictly
99 ! monotonically increasing or decreasing values.
100 !
101 ! string_array_index Match the input character string to a string
102 ! in an array/list of character strings.
103 !
104 !-----------------------------------------------------------------------
105 !---- published routines from mpp_mod ----
106 !
107 ! mpp_error, NOTE, WARNING, FATAL
108 ! mpp_error_state
109 ! mpp_pe, mpp_npes, mpp_root_pe
110 ! stdin, stdout, stderr, stdlog
111 ! mpp_chksum
112 !
113 ! mpp_clock_id, mpp_clock_begin , mpp_clock_end
114 ! MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED
115 ! CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER,
116 ! CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
117 !
118 !-----------------------------------------------------------------------
119 
120 use mpp_mod, only: mpp_error, note, warning, fatal, &
121  mpp_set_warn_level, &
122  mpp_transmit, all_pes, &
123  mpp_pe, mpp_npes, mpp_root_pe, &
124  mpp_sync, mpp_chksum, &
125  mpp_clock_begin, mpp_clock_end, &
127  mpp_clock_sync, mpp_clock_detailed, &
128  clock_component, clock_subcomponent,&
129  clock_module_driver, clock_module, &
130  clock_routine, clock_loop, &
131  clock_infra, mpp_clock_set_grain, &
133  stdin, stdout, stderr, stdlog, &
134  mpp_error_state, lowercase, &
135  uppercase, mpp_broadcast, input_nml_file, &
136  get_unit, read_input_nml
137 
138 use mpp_domains_mod, only: domain2d, mpp_define_domains, &
139  mpp_update_domains, global_data_domain, &
144 
145 use fms2_io_mod, only: fms2_io_init
146 use memutils_mod, only: print_memuse_stats, memutils_init
147 use grid2_mod, only: grid_init, grid_end
148 use fms_string_utils_mod, only: fms_c2f_string, fms_cstring2cpointer, string
149 use platform_mod, only: r4_kind, r8_kind
150 
151 use, intrinsic :: iso_c_binding
152 
153 implicit none
154 private
155 
156 ! routines for initialization and termination of module
157 public :: fms_init, fms_end
158 
160 
161 ! version logging routine (originally from fms_io)
162 public :: write_version_number
163 
164 ! miscellaneous utilities (non i/o)
165 public :: lowercase, uppercase, &
167 
168 ! public mpp interfaces
169 public :: mpp_error, note, warning, fatal, &
170  mpp_error_state, &
171  mpp_pe, mpp_npes, mpp_root_pe, &
172  stdin, stdout, stderr, stdlog, &
173  mpp_chksum, get_unit, read_input_nml
174 public :: input_nml_file
175 public :: mpp_clock_id, mpp_clock_begin, mpp_clock_end
176 public :: mpp_clock_sync, mpp_clock_detailed
177 public :: clock_component, clock_subcomponent, &
178  clock_module_driver, clock_module, &
179  clock_routine, clock_loop, clock_infra
181 !public from the old fms_io but not exists here
182 public :: string
183 
185  module procedure :: monotonic_array_r4, monotonic_array_r8
186 end interface monotonic_array
187 
188 !Balaji
189 !this is published by fms and applied to any initialized clocks
190 !of course you can go and set the flag to SYNC or DETAILED by hand
191 integer, public :: clock_flag_default
192 !> @}
193  !> Namelist read error values
194  !> @ingroup fms_mod
196  INTEGER :: multipleNMLSinFile
197  INTEGER :: badType1
198  INTEGER :: badType2
199  INTEGER :: missingVar
200  INTEGER :: NotInFile
201  END TYPE nml_errors_type
202  TYPE(nml_errors_type), SAVE :: nml_errors
203 !> @addtogroup fms_mod
204 !> @{
205 
206 !------ namelist interface -------
207 !------ adjustable severity level for warnings ------
208 
209  logical :: read_all_pe = .true. !< Read global data on all processors extracting local
210  !! part needed (TRUE) or read global data on PE0 and broadcast to all
211  !! PEs(FALSE).
212  character(len=16) :: clock_grain = 'NONE' !< The level of clock granularity used for performance
213  !! timing sections of code. Possible values in order of increasing detail
214  !! are: 'NONE', 'COMPONENT', 'SUBCOMPONENT', 'MODULE_DRIVER', 'MODULE',
215  !! 'ROUTINE', 'LOOP', and 'INFRA'. Code sections are defined using routines
216  !! in MPP module: mpp_clock_id, mpp_clock_begin, and mpp_clock_end. The fms
217  !! module makes these routines public. A list of timed code sections will be
218  !! printed to STDOUT. See the @ref mpp_mod module for more details.
219  character(len=16) :: clock_flags='NONE' !< Possible values are 'NONE', 'SYNC', or 'DETAILED'.
220  !! SYNC will give accurate information on load balance of the clocked
221  !! portion of code. DETAILED also turns on detailed message-passing
222  !! performance diagnosis. Both SYNC and DETAILED will work correctly on
223  !! innermost clock nest and distort outer clocks, and possibly the overall
224  !! code time. See the @ref mpp_mod module for more details.
225  character(len=8) :: warning_level = 'warning' !< Sets the termination condition for the WARNING
226  !! flag to interfaces error_mesg/mpp_error. set warning_level = 'fatal'
227  !! (program crashes for warning messages) or 'warning' (prints warning
228  !! message and continues).
229  integer :: stack_size = 0 !< The size in words of the MPP user stack. If stack_size > 0,
230  !! the following MPP routine is called: call mpp_set_stack_size (stack_size).
231  !! If stack_size = 0 (default) then the default size set by mpp_mod is used.
232  integer :: domains_stack_size = 0 !< The size in words of the MPP_DOMAINS user stack. If
233  !! domains_stack_size > 0, the following MPP_DOMAINS routine is called:
234  !! call mpp_domains_set_stack_size (domains_stack_size). If
235  !! domains_stack_size = 0 (default) then the default size set by
236  !! @ref mpp_domains_mod is used.
237  logical, public :: print_memory_usage = .false. !< If set to .TRUE., memory usage statistics
238  !! will be printed at various points in the code. It is used to study memory
239  !! usage, e.g to detect memory leaks.
240 
241 !------ namelist interface -------
242 
243  namelist /fms_nml/ read_all_pe, clock_grain, clock_flags, &
246 
247 ! ---- private data for check_nml_error ----
248 
249  integer, private :: num_nml_error_codes, nml_error_codes(20)
250  logical, private :: do_nml_error_init = .true.
251  private nml_error_init
252 
253 
254 ! ---- version number -----
255 
256 ! Include variable "version" to be written to log file.
257 #include<file_version.h>
258 
259  logical :: module_is_initialized = .false.
260 
261 !> @}
262 
263 !> @addtogroup fms_mod
264 !> @{
265 contains
266 
267 !#######################################################################
268 
269 !> @brief Initializes the FMS module and also calls the initialization routines for all
270 !! modules in the MPP package. Will be called automatically if the user does
271 !! not call it.
272 !! @details Initialization routine for the fms module. It also calls initialization routines
273 !! for the mpp, mpp_domains, and mpp_io modules. Although this routine
274 !! will be called automatically by other fms_mod routines, users should
275 !! explicitly call fms_init. If this routine is called more than once it will
276 !! return silently. There are no arguments.
277 !!
278 !> @throws FATAL, invalid entry for namelist variable warning_level
279 !! The namelist variable warning_level must be either 'fatal' or 'warning'(case-insensitive)
280 !!
281 !> @throws FATAL, invalid entry for namelist variable clock_grain
282 !! The namelist variable clock_grain must be one of the following values:
283 !! 'NONE', 'COMPONENT', 'SUBCOMPONENT', 'MODULE_DRIVER', 'MODULE', 'ROUTINE',
284 !! 'LOOP', or 'INFRA' (case-insensitive).
285 subroutine fms_init (localcomm, alt_input_nml_path)
286 
287 !--- needed to output the version number of constants_mod to the logfile ---
288  use constants_mod, only: constants_version=>version !pjp: PI not computed
289  interface
290  subroutine maximize_system_stacksize_limit() bind(C)
291  end subroutine
292  end interface
293 
294  integer, intent(in), optional :: localcomm
295  character(len=*), intent(in), optional :: alt_input_nml_path
296  integer :: ierr, io
297  integer :: logunitnum
298  integer :: stdout_unit !< Unit number for the stdout file
299 
300  if (module_is_initialized) return ! return silently if already called
301  module_is_initialized = .true.
302 
303 !---- Raise the system stack size limit to its maximum permissible value ----
304  call maximize_system_stacksize_limit
305 
306 !---- initialize mpp routines ----
307  if(present(localcomm)) then
308  if(present(alt_input_nml_path)) then
309  call mpp_init(localcomm=localcomm, alt_input_nml_path=alt_input_nml_path)
310  else
311  call mpp_init(localcomm=localcomm)
312  endif
313  else
314  if(present(alt_input_nml_path)) then
315  call mpp_init(alt_input_nml_path=alt_input_nml_path)
316  else
317  call mpp_init()
318  endif
319  endif
320  call mpp_domains_init()
321  call fms2_io_init()
322 #ifdef use_deprecated_io
323  call mpp_error(note, "fms_io_init: fms_io HAS BEEN DEPRECATED! "//&
324  "PLEASE REMOVE -Duse_deprecated_io FROM YOUR COMPILE FLAGS "// &
325  "AND MOVE TO FMS2_IO. CONTACT YOUR MODEL LIASISON IF YOU NEED "// &
326  "ASSISTANCE")
327 #endif
328  logunitnum = stdlog()
329 !---- read namelist input ----
330 
331  call nml_error_init() ! first initialize namelist iostat error codes
332 
333  read (input_nml_file, fms_nml, iostat=io)
334  ierr = check_nml_error(io,'fms_nml')
335 
336 !---- define mpp stack sizes if non-zero -----
337 
338  if ( stack_size > 0) call mpp_set_stack_size ( stack_size)
340 
341 !---- set severity level for warnings ----
342 
343  select case( trim(lowercase(warning_level)) )
344  case( 'fatal' )
345  call mpp_set_warn_level ( fatal )
346  case( 'warning' )
347  call mpp_set_warn_level ( warning )
348  case default
349  call error_mesg ( 'fms_init', &
350  'invalid entry for namelist variable warning_level', fatal )
351  end select
352 
353 !--- set granularity for timing code sections ---
354 
355  select case( trim(uppercase(clock_grain)) )
356  case( 'NONE' )
357  call mpp_clock_set_grain (0)
358  case( 'COMPONENT' )
359  call mpp_clock_set_grain (clock_component)
360  case( 'SUBCOMPONENT' )
361  call mpp_clock_set_grain (clock_subcomponent)
362  case( 'MODULE_DRIVER' )
363  call mpp_clock_set_grain (clock_module_driver)
364  case( 'MODULE' )
365  call mpp_clock_set_grain (clock_module)
366  case( 'ROUTINE' )
367  call mpp_clock_set_grain (clock_routine)
368  case( 'LOOP' )
369  call mpp_clock_set_grain (clock_loop)
370  case( 'INFRA' )
371  call mpp_clock_set_grain (clock_infra)
372  case default
373  call error_mesg ( 'fms_init', &
374  'invalid entry for namelist variable clock_grain', fatal )
375  end select
376 !Balaji
377  select case( trim(uppercase(clock_flags)) )
378  case( 'NONE' )
379  clock_flag_default = 0
380  case( 'SYNC' )
381  clock_flag_default = mpp_clock_sync
382  case( 'DETAILED' )
383  clock_flag_default = mpp_clock_detailed
384  case default
385  call error_mesg ( 'fms_init', &
386  'invalid entry for namelist variable clock_flags', fatal )
387  end select
388 
389 !--- write version info and namelist to logfile ---
390 
391  call write_version_number("FMS_MOD", version)
392  if (mpp_pe() == mpp_root_pe()) then
393  stdout_unit = stdlog()
394  write (stdout_unit, nml=fms_nml)
395  write (stdout_unit,*) 'nml_error_codes=', nml_error_codes(1:num_nml_error_codes)
396  endif
397 
399  call print_memuse_stats('fms_init')
400 
401 !--- output version information constants to the logfile
402  call write_version_number("CONSTANTS_MOD", constants_version)
403  call grid_init
404 
405 end subroutine fms_init
406 
407 !#######################################################################
408 
409 !> @brief Calls the termination routines for all modules in the MPP package.
410 !!
411 !> Termination routine for the fms module. It also calls destructor routines
412 !! for the mpp, mpp_domains, and mpp_io modules. If this routine is called
413 !! more than once it will return silently. There are no arguments.
414 subroutine fms_end ( )
415 
416  if (.not.module_is_initialized) return ! return silently
417 ! call fms_io_exit ! now called from coupler_end
418  call grid_end
419  call mpp_domains_exit
420  call mpp_exit
421  module_is_initialized =.false.
422 
423 end subroutine fms_end
424 
425 !#######################################################################
426 
427  !> @brief Print notes, warnings and error messages; terminates program for warning
428  !! and error messages. Usage of @ref mpp_error is preferable. (use error levels NOTE,WARNING,FATAL, see example below)
429  !! @details Print notes, warnings and error messages; and terminates the program for
430  !! error messages. This routine is a wrapper around mpp_error, and is provided
431  !! for backward compatibility. This module also publishes mpp_error,
432  !! <B>users should try to use the mpp_error interface</B>.
433  !!
434  !! <br>Example usage:
435  !! @code{.F90}
436  !! use fms_mod, only: error_mesg, FATAL, NOTE
437  !! call error_mesg ('fms_mod', 'initialization not called', FATAL)
438  !! call error_mesg ('fms_mod', 'fms_mod message', NOTE)
439  !! @endcode
440  subroutine error_mesg (routine, message, level)
441  character(len=*), intent(in) :: routine !< Routine name where the warning or error has occurred.
442  character(len=*), intent(in) :: message !< Warning or error message to be printed.
443  integer, intent(in) :: level !< Level of severity; set to NOTE, WARNING, or FATAL Termination always occurs
444  !! for FATAL, never for NOTE, and is settable for WARNING (see namelist).
445 
446 ! input:
447 ! routine name of the calling routine (character string)
448 ! message message written to output (character string)
449 ! level set to NOTE, MESSAGE, or FATAL (integer)
450 
451  if (.not.module_is_initialized) call fms_init ( )
452  call mpp_error ( routine, message, level )
453 
454  end subroutine error_mesg
455 
456 !#######################################################################
457 
458  !> @brief Facilitates the control of fatal error conditions
459  !! @details When err_msg is present, message is copied into err_msg
460  !! and the function returns a value of .true.
461  !! Otherwise calls mpp_error to terminate execution.
462  !! The intended use is as shown below.
463  !! @returns true when err_msg is present
464  !! @code{.F90}
465  !! if(fms_error_handler(routine, message, err_msg)) return
466  !! @endcode
467  function fms_error_handler(routine, message, err_msg)
468 
469  logical :: fms_error_handler
470  character(len=*), intent(in) :: routine !< Routine name where the fatal error has occurred.
471  character(len=*), intent(in) :: message !< fatal error message to be printed.
472  character(len=*), intent(out), optional :: err_msg !< When err_msg is present: err_msg = message
473 
474  fms_error_handler = .false.
475  if(present(err_msg)) then
476  err_msg = message
477  fms_error_handler = .true.
478  else
479  call mpp_error(trim(routine),trim(message),fatal)
480  endif
481 
482  end function fms_error_handler
483 
484 ! used to check the iostat argument that is
485 ! returned after reading a namelist
486 ! see the online documentation for how this routine might be used
487 
488  !> @brief Checks the iostat argument that is returned after reading a namelist
489  !! and determines if the error code is valid.
490  !! @return This function returns the input iostat value (integer) if it is an
491  !! allowable error code. If the iostat error code is not
492  !! allowable, an error message is printed and the program terminated.
493  !! @details The FMS allows multiple namelist records to reside in the same file.
494  !! Use this interface to check the iostat argument that is returned after
495  !! reading a record from the namelist file. If an invalid iostat value
496  !! is detected this routine will produce a fatal error. See the NOTE below.
497  !!
498  !! Some compilers will return non-zero iostat values when reading through
499  !! files with multiple namelist. This routine
500  !! will try skip these errors and only terminate for true namelist errors.
501  !!
502  !! <br>Examples<br>
503  !!
504  !! The following example checks if a file exists, reads a namelist input
505  !! from that file, and checks for errors in that
506  !! namelist. When the correct namelist is read and it has no errors the
507  !! routine check_nml_error will return zero and the while loop will exit.
508  !! This code segment should be used to read namelist files.
509  !! @code{.F90}
510  !! integer :: ierr, io
511  !!
512  !! read (input_nml_file, fms_nml, iostat=io)
513  !! ierr = check_nml_error(io,'fms_nml')
514  !! @endcode
515  !! @throws FATAL, Unknown error while reading namelist ...., (IOSTAT = ####)
516  !! There was an error reading the namelist specified. Carefully examine all namelist and variables
517  !! for anything incorrect (e.g. malformed, hidden characters).
518  !!
519  !! @throws FATAL, Unknown namelist, or mistyped namelist variable in namelist ...., (IOSTAT = ####)
520  !! The name list given doesn't exist in the namelist file, or a variable in the namelist is
521  !! mistyped or isn't a namelist variable.
522  INTEGER FUNCTION check_nml_error(IOSTAT, NML_NAME)
523  INTEGER, INTENT(in) :: iostat !< The iostat value returned when reading a namelist record.
524  CHARACTER(len=*), INTENT(in) :: nml_name !< The name of the namelist. This name will be printed if an error is
525  !! encountered, otherwise the name is not used.
526 
527  CHARACTER(len=256) :: err_str
528 
529  IF ( .NOT.module_is_initialized) CALL fms_init()
530 
531  check_nml_error = iostat
532 
533  ! Return on valid IOSTAT values
534  IF ( iostat <= 0 .OR.&
535  & iostat == nml_errors%multipleNMLSinFile .OR.&
536  & iostat == nml_errors%NotInFile) RETURN
537 
538  ! Everything else is a FATAL
539  IF ( (iostat == nml_errors%badType1 .OR. iostat == nml_errors%badType2) .OR. iostat == nml_errors%missingVar ) THEN
540  WRITE (err_str,*) 'Unknown namelist, or mistyped namelist variable in namelist ',trim(nml_name),', &
541  & (IOSTAT = ',iostat,')'
542  CALL error_mesg ('check_nml_error in fms_mod', err_str, fatal)
543  CALL mpp_sync()
544  ELSE
545  WRITE (err_str,*) 'Unknown error while reading namelist ',trim(nml_name),', (IOSTAT = ',iostat,')'
546  CALL error_mesg ('check_nml_error in fms_mod', err_str, fatal)
547  CALL mpp_sync()
548  END IF
549  END FUNCTION check_nml_error
550 
551 !-----------------------------------------------------------------------
552 ! private routine for initializing allowable error codes
553 
554  !> @brief Determines the IOSTAT error value for some common Namelist errors.
555  !! Also checks if the compiler returns a non-zero status if there are
556  !! multiple namelist records in a single file.
557  SUBROUTINE nml_error_init
558  ! Determines the IOSTAT error value for some common Namelist errors.
559  ! Also checks if the compiler returns a non-zero status if there are
560  ! multiple namelist records in a single file.
561  INTEGER, PARAMETER :: unit_begin = 20, unit_end = 1024
562  INTEGER :: fileunit, io_stat
563  INTEGER, DIMENSION(5) :: nml_iostats
564  LOGICAL :: opened
565 
566  ! Variables for sample namelists
567  INTEGER :: i1 !< Variables for sample namelists
568  INTEGER :: i2 !< Variables for sample namelists
569  REAL :: r1, r2
570  LOGICAL :: l1
571  namelist /a_nml/ i1, r1
572  namelist /b_nml/ i2, r2, l1
573  namelist /badtype1_nml/ i1, r1
574  namelist /badtype2_nml/ i1, r1
575  namelist /missingvar_nml/ i2, r2
576  namelist /not_in_file_nml/ i2, r2
577 
578  ! Initialize the sample namelist variables
579  i1 = 1
580  i2 = 2
581  r1 = 1.0
582  r2 = 2.0
583  l1 = .false.
584 
585  ! Create a dummy namelist file
586  IF ( mpp_pe() == mpp_root_pe() ) THEN
587  ! Find a free file unit for a scratch file
588  file_opened: DO fileunit = unit_begin, unit_end
589  INQUIRE(unit=fileunit, opened=opened)
590  IF ( .NOT.opened ) EXIT file_opened
591  END DO file_opened
592 
593 #if defined(__PGI) || defined(_CRAYFTN)
594  OPEN (unit=fileunit, file='_read_error.nml', iostat=io_stat)
595 #else
596  OPEN (unit=fileunit, status='SCRATCH', iostat=io_stat)
597 #endif
598 
599  ! Write sample namelist to the SCRATCH file.
600  WRITE (unit=fileunit, nml=a_nml, iostat=io_stat)
601  WRITE (unit=fileunit, nml=b_nml, iostat=io_stat)
602  WRITE (unit=fileunit, iostat=io_stat, fmt='(/,"&badType1_nml i1=1, r1=''bad'' /",/)')
603  WRITE (unit=fileunit, iostat=io_stat, fmt='(/,"&badType2_nml i1=1, r1=.true. /",/)')
604  WRITE (unit=fileunit, iostat=io_stat, fmt='(/,"&missingVar_nml i2=1, r2=1.0e0, l1=.true. /",/)')
605 
606  ! Rewind for reading
607  rewind(unit=fileunit)
608 
609  ! Read the second namelist from the file -- check for namelist bug
610  READ (unit=fileunit, nml=b_nml, iostat=nml_iostats(1))
611  rewind(unit=fileunit)
612 
613  ! Read in bad type 1 --- Some compilers treat the string cast differently
614  READ (unit=fileunit, nml=badtype1_nml, iostat=nml_iostats(2))
615  rewind(unit=fileunit)
616 
617  ! Read in bad type 2
618  READ (unit=fileunit, nml=badtype2_nml, iostat=nml_iostats(3))
619  rewind(unit=fileunit)
620 
621  ! Read in missing variable/misstyped
622  READ (unit=fileunit, nml=missingvar_nml, iostat=nml_iostats(4))
623  rewind(unit=fileunit)
624 
625  ! Code for namelist not in file
626  READ (unit=fileunit, nml=not_in_file_nml, iostat=nml_iostats(5))
627 
628  ! Done, close file
629  CLOSE (unit=fileunit)
630 
631  ! Some compilers don't handle the type casting as well as we would like.
632  IF ( nml_iostats(2) * nml_iostats(3) .EQ. 0 ) THEN
633  IF ( nml_iostats(2) .NE. 0 .AND. nml_iostats(3) .EQ. 0 ) THEN
634  nml_iostats(3) = nml_iostats(2)
635  ELSE IF ( nml_iostats(2) .EQ. 0 .AND. nml_iostats(3) .NE.0 ) THEN
636  nml_iostats(2) = nml_iostats(3)
637  ELSE
638  nml_iostats(2) = nml_iostats(4)
639  nml_iostats(2) = nml_iostats(4)
640  END IF
641  END IF
642  END IF
643 
644  ! Broadcast nml_errors
645  CALL mpp_broadcast(nml_iostats,5,mpp_root_pe())
646  nml_errors%multipleNMLSinFile = nml_iostats(1)
647  nml_errors%badType1 = nml_iostats(2)
648  nml_errors%badType2 = nml_iostats(3)
649  nml_errors%missingVar = nml_iostats(4)
650  nml_errors%NotInFile = nml_iostats(5)
651 
652  do_nml_error_init = .false.
653  END SUBROUTINE nml_error_init
654 
655 !#######################################################################
656 
657 !> @brief match the input character string to a string
658 !! in an array/list of character strings
659 !! @return If an exact match was found then true is returned, otherwise false is returned.
660 !! @details Tries to find a match for a character string in a list of character strings.
661 !! The match is case sensitive and disregards blank characters to the right of
662 !! the string.
663 !!
664 !! <br>Examples<br>
665 !! @code{.F90}
666 !! string = "def"
667 !! string_array = (/ "abcd", "def ", "fghi" /)
668 !!
669 !! string_array_index ( string, string_array, index )
670 !! @endcode
671 !! Returns: TRUE, index = 2
672 function string_array_index ( string, string_array, index ) result (found)
673 character(len=*), intent(in) :: string !< Character string of arbitrary length.
674 character(len=*), intent(in) :: string_array(:) !< Array/list of character strings.
675 integer, optional, intent(out) :: index !< The index of string_array where the first match was found. If
676  !! no match was found then index = 0.
677 logical :: found !< If an exact match was found then TRUE is returned, otherwise FALSE is returned.
678 integer :: i
679 
680 ! initialize this function to false
681 ! loop thru string_array and exit when a match is found
682 
683  found = .false.
684  if (present(index)) index = 0
685 
686  do i = 1, size(string_array(:))
687  ! found a string match ?
688  if ( trim(string) == trim(string_array(i)) ) then
689  found = .true.
690  if (present(index)) index = i
691  exit
692  endif
693  enddo
694 
695 end function string_array_index
696 
697 !#######################################################################
698 !> @brief Prints to the log file (or a specified unit) the version id string and
699 !! tag name.
700 subroutine write_version_number (version, tag, unit)
701  character(len=*), intent(in) :: version !> string that contains routine name
702  character(len=*), intent(in), optional :: tag !> tag name that code was checked out with
703  integer, intent(in), optional :: unit !> alternate unit number to direct output,
704  !! defaults to stdlog
705  integer :: logunit
706 
707  if (.not.module_is_initialized) call fms_init ( )
708 
709  logunit = stdlog()
710 
711  if (present(unit)) then
712  logunit = unit
713  else
714  ! only allow stdlog messages on root pe
715  if ( mpp_pe() /= mpp_root_pe() ) return
716  endif
717 
718  if (present(tag)) then
719  write (logunit,'(/,80("="),/(a))') trim(version), trim(tag)
720  else
721  write (logunit,'(/,80("="),/(a))') trim(version)
722  endif
723 
724 end subroutine write_version_number
725 
726 #include "fms_r4.fh"
727 #include "fms_r8.fh"
728 
729 end module fms_mod
730 ! <INFO>
731 ! <BUG>
732 ! Namelist error checking may not work correctly with some compilers.
733 !
734 ! Users should beware when mixing Fortran reads and read_data calls. If a
735 ! Fortran read follows read_data and namelist variable read_all_pe = FALSE
736 ! (not the default), then the code will fail. It is safest if Fortran reads
737 ! precede calls to read_data.
738 ! </BUG>
739 ! <ERROR MSG="unexpected EOF" STATUS="FATAL">
740 ! An unexpected end-of-file was encountered in a read_data call.
741 ! You may want to use the optional end argument to detect the EOF.
742 ! </ERROR>
743 ! <NOTE>
744 ! 1) If the <B>MPP</B> or <B>MPP_DOMAINS</B> stack size is exceeded the
745 ! program will terminate after printing the required size.
746 !
747 ! 2) When running on a very small number of processors or for high
748 ! resolution models the default domains_stack_size will
749 ! probably be insufficient.
750 !
751 ! 3) The following performance routines in the <B>MPP</B> module are published by this module.
752 !<PRE>
753 ! mpp_clock_id, mpp_clock_begin, mpp_clock_end
754 !</PRE>
755 ! and associated parameters that are published:
756 !<PRE>
757 ! MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, CLOCK_COMPONENT, CLOCK_SUBCOMPONENT,
758 ! CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
759 !</PRE>
760 !
761 ! 4) Here is an example of how to time a section of code.<BR/>
762 !<PRE>
763 ! use fms_mod, only: mpp_clock_id, mpp_clock_begin, &
764 ! mpp_clock_end. MPP_CLOCK_SYNC, &
765 ! CLOCK_MODULE_DRIVER
766 ! integer :: id_mycode
767 !
768 ! id_mycode = mpp_clock_id ('mycode loop', flags=MPP_CLOCK_SYNC, grain=CLOCK_MODULE_DRIVER)
769 ! call mpp_clock_begin (id_mycode)
770 ! :
771 ! :
772 ! ~~ this code will be timed ~~
773 ! :
774 ! :
775 ! call mpp_clock_end (id_mycode)
776 ! </PRE>
777 ! Note: <TT>CLOCK_MODULE_DRIVER</TT> can be replaced with
778 ! CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE,
779 ! CLOCK_LOOP, or CLOCK_INFRA.
780 !
781 ! </NOTE>
782 ! <FUTURE>
783 ! NetCDF facilities for reading and writing restart files and (IEEE32)
784 ! data files.
785 ! </FUTURE>
786 ! <FUTURE>
787 ! May possible split the FMS module into two modules.
788 !
789 ! i.general utilities (FMS_MOD) <BR/>
790 ! ii.I/O utilities (FMS_IO_MOD)
791 ! </FUTURE>
792 ! </INFO>
793 !> @}
794 ! close documentation grouping
subroutine, public fms2_io_init()
Reads the fms2_io_nml.
Definition: fms2_io.F90:395
integer function, public check_nml_error(IOSTAT, NML_NAME)
Checks the iostat argument that is returned after reading a namelist and determines if the error code...
Definition: fms.F90:523
subroutine, public write_version_number(version, tag, unit)
Prints to the log file (or a specified unit) the version id string and tag name.
Definition: fms.F90:701
subroutine, private nml_error_init
Determines the IOSTAT error value for some common Namelist errors. Also checks if the compiler return...
Definition: fms.F90:558
character(len=8) warning_level
Sets the termination condition for the WARNING flag to interfaces error_mesg/mpp_error....
Definition: fms.F90:225
logical function, public string_array_index(string, string_array, index)
match the input character string to a string in an array/list of character strings
Definition: fms.F90:673
logical read_all_pe
Read global data on all processors extracting local part needed (TRUE) or read global data on PE0 and...
Definition: fms.F90:209
subroutine, public fms_end()
Calls the termination routines for all modules in the MPP package.
Definition: fms.F90:415
character(len=16) clock_grain
The level of clock granularity used for performance timing sections of code. Possible values in order...
Definition: fms.F90:212
logical function, public fms_error_handler(routine, message, err_msg)
Facilitates the control of fatal error conditions.
Definition: fms.F90:468
integer domains_stack_size
The size in words of the MPP_DOMAINS user stack. If domains_stack_size > 0, the following MPP_DOMAINS...
Definition: fms.F90:232
subroutine, public fms_init(localcomm, alt_input_nml_path)
Initializes the FMS module and also calls the initialization routines for all modules in the MPP pack...
Definition: fms.F90:286
logical, public print_memory_usage
If set to .TRUE., memory usage statistics will be printed at various points in the code....
Definition: fms.F90:237
character(len=16) clock_flags
Possible values are 'NONE', 'SYNC', or 'DETAILED'. SYNC will give accurate information on load balanc...
Definition: fms.F90:219
subroutine, public error_mesg(routine, message, level)
Print notes, warnings and error messages; terminates program for warning and error messages....
Definition: fms.F90:441
integer stack_size
The size in words of the MPP user stack. If stack_size > 0, the following MPP routine is called: call...
Definition: fms.F90:229
Converts a C string to a Fortran string.
Namelist read error values.
Definition: fms.F90:195
character(:) function, allocatable, public string(v, fmt)
Converts a number or a Boolean value to a string.
subroutine, public grid_end
Shutdown the grid2 module.
Definition: grid2.F90:161
subroutine, public grid_init
Initialize the grid2 module.
Definition: grid2.F90:145
subroutine, public memutils_init(print_flag)
Initialize the memutils module.
Definition: memutils.F90:54
subroutine, public print_memuse_stats(text, unit, always)
Print memory usage stats to stdout, or a particular file.
Definition: memutils.F90:70
subroutine mpp_domains_init(flags)
Initialize domain decomp package.
subroutine mpp_domains_exit()
Exit mpp_domains_mod. Serves no particular purpose, but is provided should you require to re-initiali...
subroutine mpp_domains_set_stack_size(n)
Set user stack size.
Set up a domain decomposition.
These routines retrieve the axis specifications associated with the compute domains....
These routines retrieve the axis specifications associated with the data domains. The domain is a der...
These routines retrieve the axis specifications associated with the global domains....
Fill in a global array from domain-decomposed arrays.
Performs halo updates for a given domain.
The domain2D type contains all the necessary information to define the global, compute and data domai...
integer function stdout()
This function returns the current standard fortran unit numbers for output.
Definition: mpp_util.inc:42
subroutine mpp_init(flags, localcomm, test_level, alt_input_nml_path)
Initialize the mpp_mod module. Must be called before any usage.
integer function stderr()
This function returns the current standard fortran unit numbers for error messages.
Definition: mpp_util.inc:50
subroutine read_input_nml(pelist_name_in, alt_input_nml_path)
Reads an existing input nml file into a character array and broadcasts it to the non-root mpi-tasks....
Definition: mpp_util.inc:1227
subroutine mpp_clock_set_grain(grain)
Set the level of granularity of timing measurements.
Definition: mpp_util.inc:649
subroutine mpp_exit()
Finalizes process termination. To be called at the end of a run. Certain mpi implementations(openmpi)...
integer function stdlog()
This function returns the current standard fortran unit numbers for log messages. Log messages,...
Definition: mpp_util.inc:58
integer function mpp_npes()
Returns processor count for current pelist.
Definition: mpp_util.inc:420
subroutine mpp_set_stack_size(n)
Set the mpp_stack variable to be at least n LONG words long.
integer function mpp_pe()
Returns processor ID.
Definition: mpp_util.inc:406
subroutine mpp_sync(pelist, do_self)
Synchronize PEs in list.
integer function mpp_clock_id(name, flags, grain)
Return an ID for a new or existing clock.
Definition: mpp_util.inc:713
integer function stdin()
This function returns the current standard fortran unit numbers for input.
Definition: mpp_util.inc:35
Perform parallel broadcasts.
Definition: mpp.F90:1104
Calculate parallel checksums.
Definition: mpp.F90:1213
Error handler.
Definition: mpp.F90:381
Basic message-passing call.
Definition: mpp.F90:885
converts a kind=c_char to type c_ptr