FMS  2025.04
Flexible Modeling System
field_manager.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 field_manager_mod field_manager_mod
19 !> @ingroup field_manager
20 !> @brief Reads entries from a field table and stores this
21 !! information along with the type of field it belongs to.
22 !!
23 !> This allows the component models to query the field manager to see if non-default
24 !! methods of operation are desired. In essence the field table is a
25 !! powerful type of namelist. Default values can be provided for all the
26 !! fields through a namelist, individual fields can be modified through
27 !! the field table however.
28 !!
29 !> @author William Cooke
30 !!
31 !! An example of field table entries could be
32 !! <PRE>
33 !! "tracer","atmos_mod","sphum"
34 !!
35 !! "tracer","atmos_mod","sf6"
36 !! "longname","sulf_hex"
37 !! "advection_scheme_horiz","2nd_order"
38 !! "Profile_type","Fixed","surface_value = 0.0E+00"/
39 !!
40 !! "prog_tracers","ocean_mod","age_global"
41 !! horizontal-advection-scheme = mdfl_sweby
42 !! vertical-advection-scheme = mdfl_sweby
43 !! restart_file = ocean_age.res.nc
44 !! </PRE>
45 !!
46 !! The field table consists of entries in the following format.
47 !!
48 !! The first line of an entry should consist of three quoted strings.
49 !!
50 !! The first quoted string will tell the field manager what type of
51 !! field it is.
52 !!
53 !! The second quoted string will tell the field manager which model the
54 !! field is being applied to.
55 !! The supported types at present are
56 !!<PRE>
57 !! "coupler_mod" for the coupler,
58 !! "atmos_mod" for the atmosphere model,
59 !! "ocean_mod" for the ocean model,
60 !! "land_mod" for the land model, and,
61 !! "ice_mod" for the ice model.
62 !!</PRE>
63 !! The third quoted string should be a unique name that can be used as a
64 !! query.
65 !!
66 !! The second and following lines of each entry are called methods in
67 !! this context. Methods can be developed within any module and these
68 !! modules can query the field manager to find any methods that are
69 !! supplied in the field table.
70 !!
71 !! These lines can be coded quite flexibly.
72 !!
73 !! The line can consist of two or three quoted strings or a simple unquoted
74 !! string.
75 !!
76 !! If the line consists two or three quoted strings, then the first string will
77 !! be an identifier that the querying module will ask for.
78 !!
79 !! The second string will be a name that the querying module can use to
80 !! set up values for the module.
81 !!
82 !! The third string, if present, can supply parameters to the calling module that can be
83 !! parsed and used to further modify values.
84 !!
85 !! If the line consists of a simple unquoted string then quotes are not allowed
86 !! in any part of the line.
87 !!
88 !! An entry is ended with a backslash (/) as the final character in a
89 !! row.
90 !!
91 !! Comments can be inserted in the field table by having a # as the
92 !! first character in the line.
93 !!
94 !! In the example above we have three field entries.
95 !!
96 !! The first is a simple declaration of a tracer called "sphum".
97 !!
98 !! The second is for a tracer called "sf6". In this case a field named
99 !! "longname" will be given the value "sulf_hex". A field named
100 !! "advection_scheme_horiz" will be given the value "2nd_order". Finally a field
101 !! name "Profile_type" will be given a child field called "Fixed", and that field
102 !! will be given a field called "surface_value" with a real value of 0.0E+00.
103 !!
104 !! The third entry is an example of a oceanic age tracer. Note that the
105 !! method lines are formatted differently here. This is the flexibility mentioned
106 !! above.
107 !!
108 !! With these formats, a number of restrictions are required.
109 !!
110 !! The following formats are equally valid.
111 !!<PRE>
112 !! "longname","sulf_hex"
113 !! "longname = sulf_hex"
114 !! longname = sulf_hex
115 !!</PRE>
116 !! However the following is not valid.
117 !!<PRE>
118 !! longname = "sulf_hex"
119 !!</PRE>
120 !!
121 !! In the SF6 example above the last line of the entry could be written in the
122 !! following ways.
123 !!<PRE>
124 !! "Profile_type","Fixed","surface_value = 0.0E+00"/
125 !! Profile_type/Fixed/surface_value = 0.0E+00/
126 !!</PRE>
127 !!
128 !! Values supplied with fields are converted to the various types with the
129 !! following assumptions.
130 !!<PRE>
131 !! Real values : These values contain a decimal point or are in exponential format.
132 !! These values only support e or E format for exponentials.
133 !! e.g. 10.0, 1e10 and 1E10 are considered to be real numbers.
134 !!
135 !! Integer values : These values only contain numbers.
136 !! e.g 10 is an integer. 10.0 and 1e10 are not.
137 !!
138 !! Logical values : These values are supplied as one of the following formats.
139 !! T, .T., TRUE, .TRUE.
140 !! t, .t., true, .true.
141 !! F, .F., FALSE, .FALSE.
142 !! f, .f., false, .false.
143 !! These will be converted to T or F in a dump of the field.
144 !!
145 !! Character strings : These values are assumed to be strings if a character
146 !! other than an e (or E) is in the value. Numbers can be suppled in the value.
147 !! If the value does not meet the criteria for a real, integer or logical type,
148 !! it is assumed to be a character type.
149 !!</PRE>
150 !! The entries within the field table can be designed by the individual
151 !! authors of code to allow modification of their routines.
152 !!
153 
154 !> @addtogroup field_manager_mod
155 !> @{
156 module field_manager_mod
157 !TODO this variable can be removed when the legacy table is no longer used
158 #ifndef MAXFIELDS_
159 #define MAXFIELDS_ 250
160 #endif
161 
162 !TODO this variable can be removed when the legacy table is not longer used
163 #ifndef MAXFIELDMETHODS_
164 #define MAXFIELDMETHODS_ 250
165 #endif
166 
167 !
168 ! <CONTACT EMAIL="William.Cooke@noaa.gov"> William Cooke
169 ! </CONTACT>
170 !
171 ! <REVIEWER EMAIL="Richard.Slater@noaa.gov"> Richard D. Slater
172 ! </REVIEWER>
173 !
174 ! <REVIEWER EMAIL="Matthew.Harrison@noaa.gov"> Matthew Harrison
175 ! </REVIEWER>
176 !
177 ! <REVIEWER EMAIL="John.Dunne@noaa.gov"> John P. Dunne
178 ! </REVIEWER>
179 
180 use mpp_mod, only : mpp_error, &
181  fatal, &
182  note, &
183  warning, &
184  mpp_pe, &
185  mpp_root_pe, &
186  stdlog, &
187  stdout, &
188  input_nml_file
189 use fms_mod, only : lowercase, &
192 use fms2_io_mod, only: file_exists, get_instance_filename
193 use platform_mod, only: r4_kind, r8_kind, fms_path_len, fms_file_len
194 #ifdef use_yaml
195 use fm_yaml_mod
196 #endif
197 
198 implicit none
199 private
200 
201 #include<file_version.h>
202 logical :: module_is_initialized = .false.
203 
204 public :: field_manager_init !< (nfields, [table_name]) returns number of fields
205 public :: field_manager_end !< ()
206 public :: find_field_index !< (model, field_name) or (list_path)
207 public :: get_field_info !< (n,fld_type,fld_name,model,num_methods)
208  !! Returns parameters relating to field n.
209 public :: get_field_method !< (n, m, method) Returns the m-th method of field n
210 public :: get_field_methods !< (n, methods) Returns the methods related to field n
211 public :: parse !< (text, label, values) Overloaded function to parse integer,
212  !! real or character. Parse returns the number of values
213  !! decoded (> 1 => an array of values)
214 public :: fm_change_list !< (list) return success
215 public :: fm_change_root !< (list) return success
216 public :: fm_dump_list !< (list [, recursive]) return success
217 public :: fm_exists !< (field) return success
218 public :: fm_get_index !< (field) return index
219 public :: fm_get_current_list !< () return path
220 public :: fm_get_length !< (list) return length
221 public :: fm_get_type !< (field) return string
222 public :: fm_get_value !< (entry, value [, index]) return success !! generic
223 public :: fm_init_loop !< (list, iter)
224 public :: fm_loop_over_list !< (list, name, type, index) return success
225  !! (iter, name, type, index) return success
226 public :: fm_new_list !< (list [, create] [, keep]) return index
227 public :: fm_new_value !< (entry, value [, create] [, index]) return index !! generic
228 public :: fm_reset_loop !< ()
229 public :: fm_return_root !< () return success
230 public :: fm_modify_name !< (oldname, newname) return success
231 public :: fm_query_method !< (name, method_name, method_control) return success and
232  !! name and control strings
233 public :: fm_find_methods !< (list, methods, control) return success and name and
234  !! control strings.
235 public :: fm_copy_list !< (list, suffix, [create]) return index
236 private :: create_field ! (list_p, name) return field pointer
237 private :: dump_list ! (list_p, recursive, depth) return success
238 private :: find_base ! (field, path, base)
239 private :: find_field ! (field, list_p) return field pointer
240 private :: find_head ! (field, head, rest)
241 private :: find_list ! (list, list_p, create) return field pointer
242 private :: get_field ! (field, list_p) return field pointer
243 private :: initialize_module_variables ! ()
244 private :: make_list ! (list_p, name) return field pointer
245 
246 !> The length of a character string representing the field name.
247 integer, parameter, public :: fm_field_name_len = 48
248 !> The length of a character string representing character values for the field.
249 integer, parameter, public :: fm_string_len = 1024
250 !> The length of a character string representing the various types that the values of the field can take.
251 integer, parameter, public :: fm_type_name_len = 8
252 !> Number of models (ATMOS, OCEAN, LAND, ICE, COUPLER).
253 integer, parameter, public :: num_models = 5
254 !> The value returned if a field is not defined.
255 integer, parameter, public :: no_field = -1
256 !> Atmospheric model.
257 integer, parameter, public :: model_atmos = 1
258 !> Ocean model.
259 integer, parameter, public :: model_ocean = 2
260 !> Land model.
261 integer, parameter, public :: model_land = 3
262 !> Ice model.
263 integer, parameter, public :: model_ice = 4
264 !> Ice model.
265 integer, parameter, public :: model_coupler = 5
266 !> Model names, e.g. MODEL_NAMES(MODEL_OCEAN) is 'oceanic'
267 character(len=11), parameter, public, dimension(NUM_MODELS) :: &
268  model_names=(/'atmospheric','oceanic ','land ','ice ','coupler '/)
269 
270 !> @}
271 
272 !> @brief This method_type is a way to allow a component module to alter the parameters it needs
273 !! for various tracers.
274 !!
275 !> In essence this is a way to modify a namelist. A namelist can supply
276 !! default parameters for all tracers. This method will allow the user to modify these
277 !! default parameters for an individual tracer. An example could be that the user wishes to
278 !! use second order advection on a tracer and also use fourth order advection on a second
279 !! tracer within the same model run. The default advection could be second order and the
280 !! field table would then indicate that the second tracer requires fourth order advection.
281 !! This would be parsed by the advection routine.
282 !> @ingroup field_manager_mod
283 type, public :: method_type
284 
285  character(len=fm_string_len) :: method_type !< This string represents a tag that a module
286  !! using this method can key on. Typically this should
287  !! contain some reference to the module that is calling it.
288  character(len=fm_string_len) :: method_name !< This is the name of a method which the module
289  !! can parse and use to assign different default values to
290  !! a field method.
291  character(len=fm_string_len) :: method_control !< This is the string containing parameters that
292  !! the module can use as values for a field method. These should
293  !! override default values within the module.
294 end type
295 
296 !> This method_type is the same as method_type except that the
297 !! method_control string is not present. This is used when you wish to
298 !! change to a scheme within a module but do not need to pass
299 !! parameters. See @ref method_type for member information.
300 !> @ingroup field_manager_mod
301 type, public :: method_type_short
302  character(len=fm_string_len) :: method_type
303  character(len=fm_string_len) :: method_name
304 end type
305 
306 !> This is the same as method_type except that the
307 !! method_control and method_name strings are not present. This is used
308 !! when you wish to change to a scheme within a module but do not need
309 !! to pass parameters.
310 !> @ingroup field_manager_mod
311 type, public :: method_type_very_short
312  character(len=fm_string_len) :: method_type
313 end type
314 
315 !> Iterator over the field manager list
316 !> @ingroup field_manager_mod
317 type, public :: fm_list_iter_type
318  type(field_def), pointer :: ptr => null() !< pointer to the current field
319 end type fm_list_iter_type
320 
321 !> @ingroup field_manager_mod
322 type(method_type), public :: default_method
323 
324 !> @brief Returns an index corresponding to the given field name.
325 !!
326 !> Model number can be given for old method.
327 !! <br>Example usage:
328 !! @code{.F90}
329 !! value=find_field_index( model, field_name )
330 !! value=find_field_index( field_name )
331 !! @endcode
332 !> @ingroup field_manager_mod
334  module procedure find_field_index_old
335  module procedure find_field_index_new
336 end interface
337 
338 !> @brief A function to parse an integer or an array of integers,
339 !! a real or an array of reals, a string or an array of strings.
340 !!
341 !> Parse is an integer function that decodes values from a text string.
342 !! The text string has the form: "label=list" where "label" is an
343 !! arbitrary user defined label describing the values being decoded,
344 !! and "list" is a list of one or more values separated by commas.
345 !! The values may be integer, real, or character.
346 !! Parse returns the number of values decoded.
347 !! <br>Example usage:
348 !! @code{.F90}
349 !! number = parse(text, label, value)
350 !! @endcode
351 !> @ingroup field_manager_mod
352 interface parse
353  module procedure parse_real_r4
354  module procedure parse_real_r8
355  module procedure parse_reals_r4
356  module procedure parse_reals_r8
357  module procedure parse_integer
358  module procedure parse_integers
359  module procedure parse_string
360  module procedure parse_strings
361 end interface
362 
363 !> @brief An overloaded function to assign a value to a field.
364 !!
365 !> Allocate and initialize a new value and return the index.
366 !! If an error condition occurs the parameter NO_FIELD is returned.
367 !!
368 !! If the type of the field is changing (e.g. real values being transformed to
369 !! integers), then any previous values for the field are removed and replaced
370 !! by the value passed in the present call to this function.
371 !!
372 !! If append is present and .true., then index cannot be greater than 0 if
373 !! it is present.
374 !! <br> Example usage:
375 !! @code{.F90}
376 !! field_index= fm_new_value(name, value, [create], [index], [append])
377 !! @endcode
378 !> @ingroup field_manager_mod
379 interface fm_new_value
380  module procedure fm_new_value_integer
381  module procedure fm_new_value_logical
382  module procedure fm_new_value_real_r4
383  module procedure fm_new_value_real_r8
384  module procedure fm_new_value_string
385 end interface
386 
387 !> @brief An overloaded function to find and extract a value for a named field.
388 !!
389 !> Find and extract the value for name. The value may be of type real,
390 !! integer, logical or character. If a single value from an array of values
391 !! is required, an optional index can be supplied.
392 !! Return true for success and false for failure
393 !! <br> Example usage:
394 !! @code{.F90}
395 !! success = fm_get_value(name, value, index)
396 !! @endcode
397 !> @ingroup field_manager_mod
398 interface fm_get_value
399  module procedure fm_get_value_integer
400  module procedure fm_get_value_logical
401  module procedure fm_get_value_real_r4
402  module procedure fm_get_value_real_r8
403  module procedure fm_get_value_string
404 end interface
405 
406 !> @brief A function for looping over a list.
407 !!
408 !> Loop over the list, setting the name, type and index
409 !! of the next field. Return false at the end of the loop.
410 !! <br> Example usage:
411 !! @code{.F90}
412 !! success = fm_loop_over_list(list, name, field_type, index)
413 !! @endcode
414 !> @ingroup field_manager_mod
416  module procedure fm_loop_over_list_new
417  module procedure fm_loop_over_list_old
418 end interface
419 
420 character(len=17), parameter :: module_name = 'field_manager_mod'
421 character(len=33), parameter :: error_header = '==>Error from '//trim(module_name)//': '
422 character(len=35), parameter :: warn_header = '==>Warning from '//trim(module_name)//': '
423 character(len=32), parameter :: note_header = '==>Note from '//trim(module_name)//': '
424 character(len=1), parameter :: comma = ","
425 character(len=1), parameter :: list_sep = '/'
426 !TODO these variable can be removed when the legacy table is no longer used
427 character(len=1), parameter :: comment = '#'
428 character(len=1), parameter :: dquote = '"'
429 character(len=1), parameter :: equal = '='
430 character(len=1), parameter :: squote = "'"
431 !
432 integer, parameter :: null_type = 0
433 integer, parameter :: integer_type = 1
434 integer, parameter :: list_type = 2
435 integer, parameter :: logical_type = 3
436 integer, parameter :: real_type = 4
437 integer, parameter :: string_type = 5
438 integer, parameter :: num_types = 5
439 integer, parameter :: array_increment = 10
440 !TODO these variable can be removed when the legacy table is no longer used
441 integer, parameter :: MAX_FIELDS = maxfields_
442 integer, parameter :: MAX_FIELD_METHODS = maxfieldmethods_
443 !
444 
445 !> @brief Private type for internal use
446 !> @ingroup field_manager_mod
447 type, private :: field_mgr_type
448  character(len=fm_field_name_len) :: field_type
449  character(len=fm_string_len) :: field_name
450  integer :: model, num_methods
451  type(method_type), dimension(:), allocatable :: methods !< methods associated with this field name
452 end type field_mgr_type
453 
454 !TODO These two types: field_names_type and field_names_type_short
455 !! will no longer be needed when the legacy field table is not used
456 !> @brief Private type for internal use
457 !> @ingroup field_manager_mod
458 type, private :: field_names_type
459  character(len=fm_field_name_len) :: fld_type
460  character(len=fm_field_name_len) :: mod_name
461  character(len=fm_string_len) :: fld_name
462 end type field_names_type
463 
464 !> @brief Private type for internal use
465 !> @ingroup field_manager_mod
466 type, private :: field_names_type_short
467  character(len=fm_field_name_len) :: fld_type
468  character(len=fm_field_name_len) :: mod_name
469 end type field_names_type_short
470 
471 !> @brief Private type for internal use
472 !> @ingroup field_manager_mod
473 type, private :: field_def
474  character (len=fm_field_name_len) :: name
475  integer :: index
476  type (field_def), pointer :: parent => null()
477  integer :: field_type
478  integer :: length
479  integer :: array_dim
480  integer :: max_index
481  type (field_def), pointer :: first_field => null()
482  type (field_def), pointer :: last_field => null()
483  integer, allocatable, dimension(:) :: i_value
484  logical, allocatable, dimension(:) :: l_value
485  real(r8_kind), allocatable, dimension(:) :: r_value !< string to real conversion will be done at r8;
486  !! all real values will be stored as r8_kind.
487  character(len=fm_string_len), allocatable, dimension(:) :: s_value
488  type (field_def), pointer :: next => null()
489  type (field_def), pointer :: prev => null()
490 end type field_def
491 
492 !> @addtogroup field_manager_mod
493 !> @{
494 
495 type(field_mgr_type), dimension(:), allocatable, private :: fields !< fields of field_mgr_type
496 
497 character(len=FMS_PATH_LEN) :: loop_list
498 character(len=fm_type_name_len) :: field_type_name(num_types)
499 character(len=fm_field_name_len) :: save_root_name
500 ! The string set is the set of characters.
501 character(len=52) :: set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
502 ! If a character in the string being parsed matches a character within
503 ! the string set_nonexp then the string being parsed cannot be a number.
504 character(len=50) :: set_nonexp = "ABCDFGHIJKLMNOPQRSTUVWXYZabcdfghijklmnopqrstuvwxyz"
505 ! If a character in the string being parsed matches a character within
506 ! the string setnum then the string may be a number.
507 character(len=13) :: setnum = "0123456789+-."
508 integer :: num_fields = 0
509 type (field_def), pointer :: loop_list_p => null()
510 type (field_def), pointer :: current_list_p => null()
511 type (field_def), pointer :: root_p => null()
512 type (field_def), pointer :: save_root_parent_p => null()
513 type (field_def), target, save :: root
514 
515 logical :: use_field_table_yaml = .false. !< .True. if using the field_table.yaml,
516  !! .false. if using the legacy field_table
517 
518 namelist /field_manager_nml/ use_field_table_yaml
519 
520 contains
521 
522 !> @brief Routine to initialize the field manager.
523 !!
524 !> This routine reads from a file containing yaml paramaters.
525 !! These yaml parameters contain information on which schemes are
526 !! needed within various modules. The field manager does not
527 !! initialize any of those schemes however. It simply holds the
528 !! information and is queried by the appropriate module.
529 !!
530 !! The routine has two loops. The first loop initializes the my_table object
531 !! and counts the number of fields contained therein. The second loop is the
532 !! main loop that acts on each field in the my_table object, defining a list
533 !! object (in the field_manager definition) from which various fm routines may be
534 !! called, as well as populating the "fields" object and the "methods" objects
535 !! within each field object. The "fields" and "methods" objects are then used
536 !! with the subroutine new_name to append various characteristics to the list
537 !! object. Note that the "fields" and "methods" objects are also used with other
538 !! fm routines in a bit of a parallel system.
539 subroutine field_manager_init(nfields, table_name)
540 integer, intent(out), optional :: nfields !< number of fields
541 character(len=fm_string_len), intent(in), optional :: table_name !< Name of the field table, default
542 
543 if (module_is_initialized) then
544  if(present(nfields)) nfields = num_fields
545  return
546 endif
547 
549 
550 !TODO the use_field_table_yaml namelist can be removed when the legacy table is no longer in used
551 if (use_field_table_yaml) then
552  !Crash if you are not compiling with -Duse_yaml or if the field_table is present
553 #ifndef use_yaml
554  call mpp_error(fatal, "You cannot have use_field_table_yaml=.true. without compiling with -Duse_yaml")
555 #else
556  if (file_exists("field_table")) &
557  call mpp_error(fatal, "You cannot have the legacy field_table if use_field_table_yaml=.true.")
558 
559  call mpp_error(note, "field_manager_init:: You are using the yaml version of the field_table")
560  call read_field_table_yaml(nfields, table_name)
561 #endif
562 else
563  if (file_exists("field_table.yaml")) &
564  call mpp_error(fatal, "You cannot have the yaml field_table if use_field_table_yaml=.false.")
565  call mpp_error(note, "field_manager_init:: You are using the legacy version of the field_table")
566  call read_field_table_legacy(nfields, table_name)
567 endif
568 
569 end subroutine field_manager_init
570 
571 #ifdef use_yaml
572 
573 !> @brief Routine to read and parse the field table yaml
574 subroutine read_field_table_yaml(nfields, table_name)
575 integer, intent(out), optional :: nfields !< number of fields
576 character(len=*), intent(in), optional :: table_name !< Name of the field table file, default is 'field_table.yaml'
577 
578 character(len=FMS_FILE_LEN) :: tbl_name !< field_table yaml file
579 character(len=fm_string_len) :: method_control !< field_table yaml file
580 integer :: h, i, j, k, l, m !< dummy integer buffer
581 type (fmTable_t) :: my_table !< the field table
582 integer :: model !< model assocaited with the current field
583 character(len=FMS_PATH_LEN) :: list_name !< field_manager list name
584 character(len=fm_string_len) :: subparamvalue !< subparam value to be used when defining new name
585 character(len=fm_string_len) :: fm_yaml_null !< useful hack when OG subparam does not contain an equals sign
586 integer :: current_field !< field index within loop
587 integer :: index_list_name !< integer used as check for "no field"
588 integer :: subparamindex !< index to identify whether subparams exist for this field
589 logical :: fm_success !< logical for whether fm_change_list was a success
590 logical :: subparams !< logical whether subparams exist in this iteration
591 
592 character(len=FMS_FILE_LEN) :: filename !< Name of the expected field_table.yaml
593 
594 if (.not.PRESENT(table_name)) then
595  tbl_name = 'field_table.yaml'
596 else
597  tbl_name = trim(table_name)
598 endif
599 
600 call get_instance_filename(tbl_name, filename)
601 if (index(trim(filename), "ens_") .ne. 0) then
602  if (file_exists(filename) .and. file_exists(tbl_name)) &
603  call mpp_error(fatal, "Both "//trim(tbl_name)//" and "//trim(filename)//" exists, pick one!")
604 
605  !< If the end_* file does not exist, revert back to tbl_name
606  !! where every ensemble is using the same yaml
607  if (.not. file_exists(filename)) filename = tbl_name
608 endif
609 
610 if (.not. file_exists(trim(filename))) then
611  if(present(nfields)) nfields = 0
612  return
613 endif
614 
615 ! Construct my_table object
616 call build_fmtable(my_table, trim(filename))
617 
618 do h=1,size(my_table%types)
619  do i=1,size(my_table%types(h)%models)
620  do j=1,size(my_table%types(h)%models(i)%variables)
621  num_fields = num_fields + 1
622  end do
623  end do
624 end do
625 
626 allocate(fields(num_fields))
627 
628 current_field = 0
629 do h=1,size(my_table%types)
630  do i=1,size(my_table%types(h)%models)
631  select case (my_table%types(h)%models(i)%name)
632  case ('coupler_mod')
633  model = model_coupler
634  case ('atmos_mod')
635  model = model_atmos
636  case ('ocean_mod')
637  model = model_ocean
638  case ('land_mod')
639  model = model_land
640  case ('ice_mod')
641  model = model_ice
642  case default
643  call mpp_error(fatal, trim(error_header)//'The model name is unrecognised : &
644  &'//trim(my_table%types(h)%models(i)%name))
645  end select
646  do j=1,size(my_table%types(h)%models(i)%variables)
647  current_field = current_field + 1
648  list_name = list_sep//lowercase(trim(my_table%types(h)%models(i)%name))//list_sep//&
649  lowercase(trim(my_table%types(h)%name))//list_sep//&
650  lowercase(trim(my_table%types(h)%models(i)%variables(j)%name))
651  index_list_name = fm_new_list(list_name, create = .true.)
652  if ( index_list_name == no_field ) &
653  call mpp_error(fatal, trim(error_header)//'Could not set field list for '//trim(list_name))
654  fm_success = fm_change_list(list_name)
655  fields(current_field)%model = model
656  fields(current_field)%field_name = lowercase(trim(my_table%types(h)%models(i)%variables(j)%name))
657  fields(current_field)%field_type = lowercase(trim(my_table%types(h)%name))
658  fields(current_field)%num_methods = size(my_table%types(h)%models(i)%variables(j)%keys)
659  allocate(fields(current_field)%methods(fields(current_field)%num_methods))
660  if(fields(current_field)%num_methods.gt.0) then
661  subparams = (size(my_table%types(h)%models(i)%variables(j)%attributes) .gt. 0)
662  do k=1,size(my_table%types(h)%models(i)%variables(j)%keys)
663  fields(current_field)%methods(k)%method_type = &
664  lowercase(trim(my_table%types(h)%models(i)%variables(j)%keys(k)))
665  fields(current_field)%methods(k)%method_name = &
666  lowercase(trim(my_table%types(h)%models(i)%variables(j)%values(k)))
667  if (.not.subparams) then
668  call new_name(list_name, my_table%types(h)%models(i)%variables(j)%keys(k),&
669  my_table%types(h)%models(i)%variables(j)%values(k) )
670  else
671  subparamindex=-1
672  do l=1,size(my_table%types(h)%models(i)%variables(j)%attributes)
673  if(lowercase(trim(my_table%types(h)%models(i)%variables(j)%attributes(l)%paramname)).eq.&
674  lowercase(trim(fields(current_field)%methods(k)%method_type))) then
675  subparamindex = l
676  exit
677  end if
678  end do
679  if (subparamindex.eq.-1) then
680  call new_name(list_name, my_table%types(h)%models(i)%variables(j)%keys(k),&
681  my_table%types(h)%models(i)%variables(j)%values(k) )
682  else
683  do m=1,size(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%keys)
684  method_control = " "
685  subparamvalue = " "
686  if (trim(my_table%types(h)%models(i)%variables(j)%values(k)).eq.'fm_yaml_null') then
687  fm_yaml_null = ''
688  else
689  fm_yaml_null = trim(my_table%types(h)%models(i)%variables(j)%values(k))//'/'
690  end if
691  method_control = trim(my_table%types(h)%models(i)%variables(j)%keys(k))//"/"//&
692  &trim(fm_yaml_null)//&
693  &trim(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%keys(m))
694  subparamvalue = trim(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%values(m))
695  call new_name(list_name, method_control, subparamvalue)
696  end do
697  end if
698  end if
699  end do
700  end if
701  end do
702  end do
703 end do
704 
705 if (present(nfields)) nfields = num_fields
706 end subroutine read_field_table_yaml
707 
708 !> @brief Subroutine to add new values to list parameters.
709 !!
710 !> This subroutine uses input strings list_name, method_name
711 !! and val_name_in to add new values to the list. Given
712 !! list_name a new list item is created that is named
713 !! method_name and is given the value or values in
714 !! val_name_in. If there is more than 1 value in
715 !! val_name_in, these values should be comma-separated.
716 subroutine new_name_yaml ( list_name, method_name_in , val_name_in)
717 character(len=*), intent(in) :: list_name !< The name of the field that is of interest here.
718 character(len=*), intent(in) :: method_name_in !< The name of the method that values are
719  !! being supplied for.
720 character(len=*), intent(inout) :: val_name_in !< The value or values that will be parsed and
721  !! used as the value when creating a new field or fields.
722 
723 character(len=fm_string_len) :: method_name !< name of method to be attached to new list
724 character(len=fm_string_len) :: val_name !< value name (to be converted to appropriate type)
725 integer, dimension(:), allocatable :: end_val !< end values in comma separated list
726 integer, dimension(:), allocatable :: start_val !< start values in comma separated list
727 integer :: i !< loop index
728 integer :: index_t !< appending index
729 integer :: num_elem !< number of elements in comma list
730 integer :: val_int !< value when converted to integer
731 integer :: val_type !< value type represented as integer for use in select case
732 logical :: append_new !< whether or not to append to existing list structure
733 logical :: val_logic !< value when converted to logical
734 real(r8_kind) :: val_real !< value when converted to real.
735  !! All strings will be converted to r8_kind reals.
736 
737 call strip_front_blanks(val_name_in)
738 method_name = trim(method_name_in)
739 call strip_front_blanks(method_name)
740 
741 index_t = 1
742 num_elem = 1
743 append_new = .false.
744 
745 ! If the array of values being passed in is a comma delimited list then count
746 ! the number of elements.
747 
748 do i = 1, len_trim(val_name_in)
749  if ( val_name_in(i:i) == comma ) then
750  num_elem = num_elem + 1
751  endif
752 enddo
753 
754 allocate(start_val(num_elem))
755 allocate(end_val(num_elem))
756 start_val(1) = 1
757 end_val(:) = len_trim(val_name_in)
758 
759 num_elem = 1
760 do i = 1, len_trim(val_name_in)
761  if ( val_name_in(i:i) == comma ) then
762  end_val(num_elem) = i-1
763  start_val(num_elem+1) = i+1
764  num_elem = num_elem + 1
765  endif
766 enddo
767 
768 do i = 1, num_elem
769 
770  if ( i .gt. 1 .or. index_t .eq. 0 ) then
771  append_new = .true.
772  index_t = 0 ! If append is true then index must be <= 0
773  endif
774  val_type = string_type ! Assume it is a string
775  val_name = val_name_in(start_val(i):end_val(i))
776  call strip_front_blanks(val_name)
777 
778  if ( scan(val_name(1:1), setnum ) > 0 ) then
779  if ( scan(val_name, set_nonexp ) .le. 0 ) then
780  if ( scan(val_name, '.') > 0 .or. scan(val_name, 'e') > 0 .or. scan(val_name, 'E') > 0) then
781  read(val_name, *) val_real
782  val_type = real_type
783  else
784  read(val_name, *) val_int
785  val_type = integer_type
786  endif
787  endif
788  endif
789 
790  if ( len_trim(val_name) == 1 .or. len_trim(val_name) == 3) then
791  if ( val_name == 't' .or. val_name == 'T' .or. val_name == '.t.' .or. val_name == '.T.' ) then
792  val_logic = .true.
793  val_type = logical_type
794  endif
795  if ( val_name == 'f' .or. val_name == 'F' .or. val_name == '.f.' .or. val_name == '.F.' ) then
796  val_logic = .false.
797  val_type = logical_type
798  endif
799  endif
800  if ( trim(lowercase(val_name)) == 'true' .or. trim(lowercase(val_name)) == '.true.' ) then
801  val_logic = .true.
802  val_type = logical_type
803  endif
804  if ( trim(lowercase(val_name)) == 'false' .or. trim(lowercase(val_name)) == '.false.' ) then
805  val_logic = .false.
806  val_type = logical_type
807  endif
808 
809  select case(val_type)
810 
811  case (integer_type)
812  if ( fm_new_value( method_name, val_int, create = .true., index = index_t, append = append_new ) < 0 ) &
813  call mpp_error(fatal, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
814  ' (I) for '//trim(list_name))
815 
816  case (logical_type)
817  if ( fm_new_value( method_name, val_logic, create = .true., index = index_t, append = append_new) < 0 ) &
818  call mpp_error(fatal, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
819  ' (L) for '//trim(list_name))
820 
821  case (real_type)
822  if ( fm_new_value( method_name, val_real, create = .true., index = index_t, append = append_new) < 0 ) &
823  call mpp_error(fatal, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
824  ' (R) for '//trim(list_name))
825 
826  case (string_type)
827  if ( fm_new_value( method_name, val_name, create = .true., index = index_t, append = append_new) < 0 ) &
828  call mpp_error(fatal, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
829  ' (S) for '//trim(list_name))
830  case default
831  call mpp_error(fatal, trim(error_header)//'Could not find a valid type to set the '//trim(method_name)//&
832  ' for '//trim(list_name))
833 
834  end select
835 
836 enddo
837  deallocate(start_val)
838  deallocate(end_val)
839 
840 end subroutine new_name_yaml
841 #endif
842 
843 !> @brief Routine to read and parse the field table yaml
844 !!
845 !> This routine reads from a file containing formatted strings.
846 !! These formatted strings contain information on which schemes are
847 !! needed within various modules. The field manager does not
848 !! initialize any of those schemes however. It simply holds the
849 !! information and is queried by the appropriate module.
850 subroutine read_field_table_legacy(nfields, table_name)
851 
852 integer, intent(out), optional :: nfields !< number of fields
853 character(len=fm_string_len), intent(in), optional :: table_name !< Name of the field table, default
854  !! is 'field_table'
855 
856 character(len=1024) :: record
857 character(len=fm_string_len) :: control_str
858 character(len=FMS_PATH_LEN) :: list_name
859 character(len=fm_string_len) :: method_name
860 character(len=fm_string_len) :: name_str
861 character(len=fm_string_len) :: type_str
862 character(len=fm_string_len) :: val_name
863 character(len=fm_string_len) :: tbl_name
864 integer :: control_array(MAX_FIELDS,3)
865 integer :: endcont
866 integer :: icount
867 integer :: index_list_name
868 integer :: iunit
869 integer :: l
870 integer :: log_unit
871 integer :: ltrec
872 integer :: m
873 integer :: midcont
874 integer :: model
875 integer :: startcont
876 integer :: io_status
877 logical :: flag_method
878 logical :: fm_success
879 type(field_names_type_short) :: text_names_short
880 type(field_names_type) :: text_names
881 type(method_type_short) :: text_method_short
882 type(method_type) :: text_method
883 type(method_type_very_short) :: text_method_very_short
884 
885 if (.not.PRESENT(table_name)) then
886  tbl_name = 'field_table'
887 else
888  tbl_name = trim(table_name)
889 endif
890 if (.not. file_exists(trim(tbl_name))) then
891  if(present(nfields)) nfields = 0
892  return
893 endif
894 
895 allocate(fields(max_fields))
896 
897 open(newunit=iunit, file=trim(tbl_name), action='READ', iostat=io_status)
898 if(io_status/=0) call mpp_error(fatal, 'field_manager_mod: Error in opening file '//trim(tbl_name))
899 !write_version_number should precede all writes to stdlog from field_manager
900 call write_version_number("FIELD_MANAGER_MOD", version)
901 log_unit = stdlog()
902 do while (.true.)
903  read(iunit,'(a)',end=89,err=99) record
904  write( log_unit,'(a)' )record
905  if (record(1:1) == "#" ) cycle
906  ltrec = len_trim(record)
907  if (ltrec .le. 0 ) cycle ! Blank line
908 
909 
910  icount = 0
911  do l= 1, ltrec
912  if (record(l:l) == '"' ) then
913  icount = icount + 1
914  endif
915  enddo
916  if (icount > 6 ) then
917  call mpp_error(fatal,trim(error_header)//'Too many fields in field table header entry.'//trim(record))
918  endif
919 
920  select case (icount)
921  case (6)
922  read(record,*,end=79,err=79) text_names
923  text_names%fld_type = lowercase(trim(text_names%fld_type))
924  text_names%mod_name = lowercase(trim(text_names%mod_name))
925  text_names%fld_name = lowercase(trim(text_names%fld_name))
926  case(4)
927 ! If there is no control string then the last string can be omitted and there are only 4 '"' in the record.
928  read(record,*,end=79,err=79) text_names_short
929  text_names%fld_type = lowercase(trim(text_names_short%fld_type))
930  text_names%mod_name = lowercase(trim(text_names_short%mod_name))
931  text_names%fld_name = lowercase(trim(text_names_short%mod_name))
932  case(2)
933 ! If there is only the method_type string then the last 2 strings need to be blank and there
934 ! are only 2 '"' in the record.
935  read(record,*,end=79,err=79) text_names_short
936  text_names%fld_type = lowercase(trim(text_names_short%fld_type))
937  text_names%mod_name = lowercase(trim(text_names_short%mod_name))
938  text_names%fld_name = lowercase(trim(text_names_short%mod_name))
939  case default
940 ! There is an unterminated or unquoted string in the field table entry.
941  text_names%fld_type = " "
942  text_names%mod_name = lowercase(trim(record))
943  text_names%fld_name = " "
944  end select
945 
946 ! Create a list with Rick Slaters field manager code
947 
948  list_name = list_sep//trim(text_names%mod_name)//list_sep//trim(text_names%fld_type)//&
949  list_sep//trim(text_names%fld_name)
950 
951  index_list_name = fm_new_list(list_name, create = .true.)
952  if ( index_list_name == no_field ) &
953  call mpp_error(fatal, trim(error_header)//'Could not set field list for '//trim(list_name))
954 
955  fm_success = fm_change_list(list_name)
956  select case (text_names%mod_name)
957  case ('coupler_mod')
958  model = model_coupler
959  case ('atmos_mod')
960  model = model_atmos
961  case ('ocean_mod')
962  model = model_ocean
963  case ('land_mod')
964  model = model_land
965  case ('ice_mod')
966  model = model_ice
967  case default
968  call mpp_error(fatal, trim(error_header)//'The model name is unrecognised : '//trim(text_names%mod_name))
969  end select
970  if (find_field_index(list_name) > 0) then
971  num_fields = num_fields + 1
972 
973  if (num_fields > max_fields) call mpp_error(fatal,trim(error_header)//'max fields exceeded')
974  fields(num_fields)%model = model
975  fields(num_fields)%field_name = lowercase(trim(text_names%fld_name))
976  fields(num_fields)%field_type = lowercase(trim(text_names%fld_type))
977  fields(num_fields)%num_methods = 0
978  allocate(fields(num_fields)%methods(max_field_methods))
979  call check_for_name_duplication
980 
981 ! Check to see that the first line is not the only line
982  if ( record(len_trim(record):len_trim(record)) == list_sep) cycle
983 
984  flag_method = .true.
985  m = 1
986  do while (flag_method)
987  read(iunit,'(a)',end=99,err=99) record
988 ! If the line is blank then fetch the next line.
989  if (len_trim(record) .le. 0) cycle
990 ! If the last character in the line is / then this is the end of the field methods
991  if ( record(len_trim(record):len_trim(record)) == list_sep) then
992  flag_method = .false.
993  if (len_trim(record) == 1) cycle
994  record = record(:len_trim(record)-1) ! Remove the end of field method marker
995  endif
996 ! If the line is now blank, after removing the field separator marker, then fetch the next line.
997  if (len_trim(record) .le. 0) cycle
998 ! If the first character in the line is # then it is treated as a comment
999  if (record(1:1) == comment ) cycle
1000 
1001  icount = 0
1002  do l= 1, len_trim(record)
1003  if (record(l:l) == dquote ) then
1004  icount = icount + 1
1005  endif
1006  enddo
1007  if (icount > 6 ) call mpp_error(fatal,trim(error_header)//'Too many fields in field entry.'//trim(record))
1008 
1009  if (.not. fm_change_list( list_name)) &
1010  call mpp_error(fatal, trim(error_header)//'Could not change to '//trim(list_name)//' list')
1011 
1012  select case (icount)
1013  case (6)
1014  read(record,*,end=99,err=99) text_method
1015  fields(num_fields)%methods(m)%method_type = lowercase(trim(text_method%method_type))
1016  fields(num_fields)%methods(m)%method_name = lowercase(trim(text_method%method_name))
1017  fields(num_fields)%methods(m)%method_control = lowercase(trim(text_method%method_control))
1018 
1019  type_str = text_method%method_type
1020  name_str = text_method%method_name
1021  control_str = text_method%method_control
1022 
1023  case(4)
1024 ! If there is no control string then the last string can be omitted and there are only 4 '"' in the record.
1025  read(record,*,end=99,err=99) text_method_short
1026  fields(num_fields)%methods(m)%method_type =&
1027  & lowercase(trim(text_method_short%method_type))
1028  fields(num_fields)%methods(m)%method_name =&
1029  & lowercase(trim(text_method_short%method_name))
1030  fields(num_fields)%methods(m)%method_control = " "
1031 
1032  type_str = text_method_short%method_type
1033  name_str = ""
1034  control_str = text_method_short%method_name
1035 
1036  case(2)
1037 ! If there is only the method_type string then the last 2 strings need to be blank and there
1038 ! are only 2 '"' in the record.
1039  read(record,*,end=99,err=99) text_method_very_short
1040  fields(num_fields)%methods(m)%method_type = lowercase(trim(text_method_very_short%method_type))
1041  fields(num_fields)%methods(m)%method_name = " "
1042  fields(num_fields)%methods(m)%method_control = " "
1043 
1044  type_str = ""
1045  name_str = ""
1046  control_str = text_method_very_short%method_type
1047 
1048  case(0)
1049  read(record,'(A)',end=99,err=99) control_str
1050  type_str = ""
1051  name_str = ""
1052 
1053  case default
1054  call mpp_error(fatal,trim(error_header)//'Unterminated field in field entry.'//trim(record))
1055  end select
1056 
1057 ! This section of code breaks the control string into separate strings.
1058 ! The array control_array contains the following parameters.
1059 ! control_array(:,1) = index within control_str of the first character of the name.
1060 ! control_array(:,2) = index within control_str of the equal sign
1061 ! control_array(:,3) = index within control_str of the last character of the value.
1062 !
1063 ! control_array(:,1) -> control_array(:,2) -1 = name of the parameter.
1064 ! control_array(:,2)+1 -> control_array(:,3) = value of the parameter.
1065 
1066  ltrec= len_trim(control_str)
1067  control_array(:,1) = 1
1068  control_array(:,2:3) = ltrec
1069  icount = 0
1070  do l= 1, ltrec
1071  if (control_str(l:l) == equal ) then
1072  icount = icount + 1
1073  control_array(icount,2) = l ! Middle of string
1074  elseif (control_str(l:l) == comma ) then
1075  if (icount .eq. 0) then
1076  call mpp_error(fatal,trim(error_header) // &
1077  ' Bad format for field entry (comma without equals sign): ''' // &
1078  trim(control_str) // '''')
1079  elseif (icount .gt. max_fields) then
1080  call mpp_error(fatal,trim(error_header) // &
1081  ' Too many fields in field entry: ''' // &
1082  trim(control_str) // '''')
1083  else
1084  control_array(icount,3) = l-1 !End of previous string
1085  control_array(min(max_fields,icount+1),1) = l+1 !Start of next string
1086  endif
1087  endif
1088  enddo
1089 
1090  ! Make sure that we point to the end of the string (minus any trailing comma)
1091  ! for the last set of values. This fixes the case where the last set of values
1092  ! is a comma separated list
1093 
1094  if (control_str(ltrec:ltrec) .ne. comma) then
1095  control_array(max(1,icount),3) = ltrec
1096  endif
1097 
1098  if ( icount == 0 ) then
1099  method_name = type_str
1100  if (len_trim(method_name) > 0 ) then
1101  method_name = trim(method_name)//list_sep// trim(name_str)
1102  else
1103  method_name = trim(name_str)
1104  endif
1105  val_name = control_str
1106 
1107  call new_name(list_name, method_name, val_name )
1108 
1109  else
1110 
1111  do l = 1,icount
1112  startcont = control_array(l,1)
1113  midcont = control_array(l,2)
1114  endcont = control_array(l,3)
1115 
1116  method_name = trim(type_str)
1117  if (len_trim(method_name) > 0 ) then
1118  method_name = trim(method_name)//list_sep// trim(name_str)
1119  else
1120  method_name = trim(name_str)
1121  endif
1122 
1123  if (len_trim(method_name) > 0 ) then
1124  method_name = trim(method_name)//list_sep//&
1125  trim(control_str(startcont:midcont-1))
1126  else
1127  method_name = trim(control_str(startcont:midcont-1))
1128  endif
1129  val_name = trim(control_str(midcont+1:endcont))
1130 
1131  call new_name(list_name, method_name, val_name )
1132  enddo
1133 
1134  endif
1135 
1136  fields(num_fields)%num_methods = fields(num_fields)%num_methods + 1
1137  if (fields(num_fields)%num_methods > max_field_methods) &
1138  call mpp_error(fatal,trim(error_header)//'Maximum number of methods for field exceeded')
1139  m = m + 1
1140  enddo
1141  else
1142  flag_method = .true.
1143  do while (flag_method)
1144  read(iunit,'(A)',end=99,err=99) record
1145  if ( record(len_trim(record):len_trim(record)) == list_sep) then
1146  flag_method = .false.
1147  endif
1148  enddo
1149  endif
1150 79 continue
1151 enddo
1152 
1153 89 continue
1154 close(iunit, iostat=io_status)
1155 if(io_status/=0) call mpp_error(fatal, 'field_manager_mod: Error in closing file '//trim(tbl_name))
1156 
1157 
1158 if(present(nfields)) nfields = num_fields
1159 
1160 default_method%method_type = 'none'
1161 default_method%method_name = 'none'
1162 default_method%method_control = 'none'
1163 return
1164 
1165 99 continue
1166 
1167 call mpp_error(fatal,trim(error_header)//' Error reading field table. Record = '//trim(record))
1168 
1169 end subroutine read_field_table_legacy
1170 
1171 subroutine check_for_name_duplication
1172 integer :: i
1173 
1174 ! Check that name is unique amoung fields of the same field_type and model.
1175 do i=1,num_fields-1
1176  if ( fields(i)%field_type == fields(num_fields)%field_type .and. &
1177  fields(i)%model == fields(num_fields)%model .and. &
1178  fields(i)%field_name == fields(num_fields)%field_name ) then
1179  if (mpp_pe() .eq. mpp_root_pe()) then
1180  call mpp_error(warning,'Error in field_manager_mod. Duplicate field name: Field type='//&
1181  trim(fields(i)%field_type)// &
1182  ', Model='//trim(model_names(fields(i)%model))// &
1183  ', Duplicated name='//trim(fields(i)%field_name))
1184  endif
1185  endif
1186 enddo
1187 
1188 end subroutine check_for_name_duplication
1189 
1190 !> @brief Subroutine to add new values to list parameters.
1191 !!
1192 !> This subroutine uses input strings list_name, method_name
1193 !! and val_name_in to add new values to the list. Given
1194 !! list_name a new list item is created that is named
1195 !! method_name and is given the value or values in
1196 !! val_name_in. If there is more than 1 value in
1197 !! val_name_in, these values should be comma-separated.
1198 subroutine new_name ( list_name, method_name_in , val_name_in)
1199 character(len=*), intent(in) :: list_name !< The name of the field that is of interest here.
1200 character(len=*), intent(in) :: method_name_in !< The name of the method that values are
1201  !! being supplied for.
1202 character(len=*), intent(inout) :: val_name_in !< The value or values that will be parsed and
1203  !! used as the value when creating a new field or fields.
1204 
1205 character(len=fm_string_len) :: method_name
1206 character(len=fm_string_len) :: val_name
1207 integer, dimension(MAX_FIELDS) :: end_val
1208 integer, dimension(MAX_FIELDS) :: start_val
1209 integer :: i
1210 integer :: index_t
1211 integer :: left_br
1212 integer :: num_elem
1213 integer :: out_unit
1214 integer :: right_br
1215 integer :: val_int
1216 integer :: val_type
1217 logical :: append_new
1218 logical :: val_logic
1219 real(r8_kind) :: val_real !< all reals converted from string will be in r8_kind precision
1220 integer :: length
1221 
1222 call strip_front_blanks(val_name_in)
1223 method_name = trim(method_name_in)
1224 call strip_front_blanks(method_name)
1225 
1226 index_t = 1
1227 num_elem = 1
1228 append_new = .false.
1229 start_val(1) = 1
1230 end_val(:) = len_trim(val_name_in)
1231 
1232 ! If the array of values being passed in is a comma delimited list then count
1233 ! the number of elements.
1234 
1235 do i = 1, len_trim(val_name_in)
1236  if ( val_name_in(i:i) == comma ) then
1237  end_val(num_elem) = i-1
1238  start_val(num_elem+1) = i+1
1239  num_elem = num_elem + 1
1240  endif
1241 enddo
1242 
1243 ! Check to see if this is an array element of form array[x] = value
1244 left_br = scan(method_name,'[')
1245 right_br = scan(method_name,']')
1246 if ( num_elem .eq. 1 ) then
1247  if ( left_br > 0 .and. right_br == 0 ) &
1248  call mpp_error(fatal, trim(error_header)//"Left bracket present without right bracket in "//trim(method_name))
1249  if ( left_br== 0 .and. right_br > 0 ) &
1250  call mpp_error(fatal, trim(error_header)//"Right bracket present without left bracket in "//trim(method_name))
1251  if ( left_br > 0 .and. right_br > 0 ) then
1252  if ( scan( method_name(left_br+1:right_br -1), set ) > 0 ) &
1253  call mpp_error(fatal, trim(error_header)//"Using a non-numeric value for index in "//trim(method_name))
1254  read(method_name(left_br+1:right_br -1), *) index_t
1255  method_name = method_name(:left_br -1)
1256  endif
1257 else
1258 ! If there are multiple values then there cannot be a bracket in method_name.
1259  if ( left_br > 0 .or. right_br > 0 ) &
1260  call mpp_error(fatal, &
1261  trim(error_header)//"Using a comma delimited list with an indexed array element in "//trim(method_name))
1262 endif
1263 
1264 do i = 1, num_elem
1265 
1266  if ( i .gt. 1 .or. index_t .eq. 0 ) then
1267  append_new = .true.
1268  index_t = 0 ! If append is true then index must be <= 0
1269  endif
1270  val_type = string_type ! Assume it is a string
1271  val_name = val_name_in(start_val(i):end_val(i))
1272  call strip_front_blanks(val_name)
1273 
1274 !
1275 ! if the string starts and ends with matching single quotes, then this is a string
1276 ! if there are quotes which do not match, then this is an error
1277 !
1278 
1279  length = len_trim(val_name)
1280  if (val_name(1:1) .eq. squote) then
1281 
1282  if (val_name(length:length) .eq. squote) then
1283  val_name = val_name(2:length-1)//repeat(" ",len(val_name)-length+2)
1284  val_type = string_type
1285  elseif (val_name(length:length) .eq. dquote) then
1286  call mpp_error(fatal, trim(error_header) // ' Quotes do not match in ' // trim(val_name) // &
1287  ' for ' // trim(method_name) // ' of ' // trim(list_name))
1288  else
1289  call mpp_error(fatal, trim(error_header) // ' No trailing quote in ' // trim(val_name) // &
1290  ' for ' // trim(method_name) // ' of ' // trim(list_name))
1291  endif
1292 
1293  elseif (val_name(1:1) .eq. dquote .or. val_name(length:length) .eq. dquote) then
1294 
1295  call mpp_error(fatal, trim(error_header) // ' Double quotes not allowed in ' // trim(val_name) // &
1296  ' for ' // trim(method_name) // ' of ' // trim(list_name))
1297 
1298  elseif (val_name(length:length) .eq. squote) then
1299 
1300  call mpp_error(fatal, trim(error_header) // ' No leading quote in ' // trim(val_name) // &
1301  ' for ' // trim(method_name) // ' of ' // trim(list_name))
1302 
1303  else
1304 ! If the string to be parsed is a real then all the characters must be numeric,
1305 ! be a plus/minus, be a decimal point or, for exponentials, be e or E.
1306 
1307 ! If a string is an integer, then all the characters must be numeric.
1308 
1309  if ( scan(val_name(1:1), setnum ) > 0 ) then
1310 
1311 ! If there is a letter in the name it may only be e or E
1312 
1313  if ( scan(val_name, set_nonexp ) .le. 0 ) then
1314 ! It is real if there is a . in the name or the value appears exponential
1315  if ( scan(val_name, '.') > 0 .or. scan(val_name, 'e') > 0 .or. scan(val_name, 'E') > 0) then
1316  read(val_name, *) val_real
1317  val_type = real_type
1318  else
1319  read(val_name, *) val_int
1320  val_type = integer_type
1321  endif
1322  endif
1323 
1324  endif
1325 
1326 ! If val_name is t/T or f/F then this is a logical flag.
1327  if ( len_trim(val_name) == 1 .or. len_trim(val_name) == 3) then
1328  if ( val_name == 't' .or. val_name == 'T' .or. val_name == '.t.' .or. val_name == '.T.' ) then
1329  val_logic = .true.
1330  val_type = logical_type
1331  endif
1332  if ( val_name == 'f' .or. val_name == 'F' .or. val_name == '.f.' .or. val_name == '.F.' ) then
1333  val_logic = .false.
1334  val_type = logical_type
1335  endif
1336  endif
1337  if ( trim(lowercase(val_name)) == 'true' .or. trim(lowercase(val_name)) == '.true.' ) then
1338  val_logic = .true.
1339  val_type = logical_type
1340  endif
1341  if ( trim(lowercase(val_name)) == 'false' .or. trim(lowercase(val_name)) == '.false.' ) then
1342  val_logic = .false.
1343  val_type = logical_type
1344  endif
1345  endif
1346 
1347  select case(val_type)
1348 
1349  case (integer_type)
1350  if ( fm_new_value( method_name, val_int, create = .true., index = index_t, append = append_new ) < 0 ) &
1351  call mpp_error(fatal, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
1352  ' (I) for '//trim(list_name))
1353 
1354  case (logical_type)
1355  if ( fm_new_value( method_name, val_logic, create = .true., index = index_t, append = append_new) < 0 ) &
1356  call mpp_error(fatal, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
1357  ' (L) for '//trim(list_name))
1358 
1359  case (real_type)
1360  if ( fm_new_value( method_name, val_real, create = .true., index = index_t, append = append_new) < 0 ) &
1361  call mpp_error(fatal, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
1362  ' (R) for '//trim(list_name))
1363 
1364  case (string_type)
1365  if ( fm_new_value( method_name, val_name, create = .true., index = index_t, append = append_new) < 0 ) &
1366  call mpp_error(fatal, trim(error_header)//'Could not set "' // trim(val_name) // '" for '//trim(method_name)//&
1367  ' (S) for '//trim(list_name))
1368  case default
1369  call mpp_error(fatal, trim(error_header)//'Could not find a valid type to set the '//trim(method_name)//&
1370  ' for '//trim(list_name))
1371 
1372  end select
1373 
1374 enddo
1375 
1376 end subroutine new_name
1377 
1378 !> @brief Destructor for field manager.
1379 !!
1380 !> This subroutine deallocates allocated variables (if allocated) and
1381 !! changes the initialized flag to false.
1383 integer :: j
1384 
1385 module_is_initialized = .false.
1386 
1387 do j=1,size(fields)
1388  if(allocated(fields(j)%methods)) deallocate(fields(j)%methods)
1389 end do
1390 if(allocated(fields)) deallocate(fields)
1391 
1392 end subroutine field_manager_end
1393 
1394 !> @brief A routine to strip whitespace from the start of character strings.
1395 !!
1396 !> This subroutine removes spaces and tabs from the start of a character string.
1397 subroutine strip_front_blanks(name)
1398 
1399 character(len=*), intent(inout) :: name !< name to remove whitespace from
1400 
1401 name = trim(adjustl(name))
1402 end subroutine strip_front_blanks
1403 
1404 !> @brief Function to return the index of the field
1405 !!
1406 !> This function when passed a model number and a field name will
1407 !! return the index of the field within the field manager. This index
1408 !! can be used to access other information from the field manager.
1409 !! @returns The index of the field corresponding to field_name.
1410 function find_field_index_old(model, field_name)
1411 
1412 integer :: find_field_index_old
1413 integer, intent(in) :: model !< The number indicating which model is used.
1414 character(len=*), intent(in) :: field_name !< The name of the field that an index is being requested for.
1415 
1416 integer :: i
1417 
1419 
1420 do i=1,num_fields
1421  if (fields(i)%model == model .and. fields(i)%field_name == lowercase(field_name)) then
1423  return
1424  endif
1425 enddo
1426 
1427 end function find_field_index_old
1428 
1429 !> @returns index of the field corresponding to field_name
1430 function find_field_index_new(field_name)
1431 
1432 integer :: find_field_index_new
1433 character(len=*), intent(in) :: field_name !< The path to the name of the field that an index is
1434  !! being requested for.
1435 
1437 
1438 find_field_index_new = fm_get_index(field_name)
1439 
1440 end function find_field_index_new
1441 
1442 !> @brief This routine allows access to field information given an index.
1443 !!
1444 !> When passed an index, this routine will return the type of field,
1445 !! the name of the field, the model which the field is associated and
1446 !! the number of methods associated with the field.
1447 !! <br>Example usage:
1448 !! @code{.F90}
1449 !! call get_field_info( n,fld_type,fld_name,model,num_methods )
1450 !! @endcode
1451 subroutine get_field_info(n,fld_type,fld_name,model,num_methods)
1452 integer, intent(in) :: n !< index of field
1453 character (len=*),intent(out) :: fld_type !< field type
1454 character (len=*),intent(out) :: fld_name !< name of the field
1455 integer, intent(out) :: model !< number indicating which model is used
1456 integer, intent(out) :: num_methods !< number of methods
1457 
1458 if (n < 1 .or. n > num_fields) call mpp_error(fatal,trim(error_header)//'Invalid field index')
1459 
1460 fld_type = fields(n)%field_type
1461 fld_name = fields(n)%field_name
1462 model = fields(n)%model
1463 num_methods = fields(n)%num_methods
1464 
1465 end subroutine get_field_info
1466 
1467 !> @brief A routine to get a specified method
1468 !!
1469 !> This routine, when passed a field index and a method index will
1470 !! return the method text associated with the field(n) method(m).
1471 subroutine get_field_method(n,m,method)
1472 
1473 integer, intent(in) :: n !< index of field
1474 integer, intent(in) :: m !< index of method
1475 type(method_type) ,intent(inout) :: method !< the m-th method of field with index n
1476 
1477 if (n < 1 .or. n > num_fields) call mpp_error(fatal,trim(error_header)//'Invalid field index')
1478 if (m < 1 .or. m > fields(n)%num_methods) call mpp_error(fatal,trim(error_header)//'Invalid method index')
1479 
1480  method = fields(n)%methods(m)
1481 
1482 end subroutine get_field_method
1483 
1484 !> @brief A routine to obtain all the methods associated with a field.
1485 !!
1486 !> When passed a field index, this routine will return the text
1487 !! associated with all the methods attached to the field.
1488 subroutine get_field_methods(n,methods)
1489 
1490 integer, intent(in) :: n !< field index
1491 type(method_type),intent(inout) :: methods(:) !< an array of methods for field with index n
1492 
1493  if (n < 1 .or. n > num_fields) &
1494  call mpp_error(fatal,trim(error_header)//'Invalid field index')
1495 
1496  if (size(methods(:)) < fields(n)%num_methods) &
1497  call mpp_error(fatal,trim(error_header)//'Method array too small')
1498 
1499  methods = default_method
1500  methods(1:fields(n)%num_methods) = fields(n)%methods(1:fields(n)%num_methods)
1501 
1502 end subroutine get_field_methods
1503 
1504 !> @returns The number of values that have been decoded. This allows
1505 !! a user to define a large array and fill it partially with
1506 !! values from a list. This should be the size of the value array.
1507 function parse_integers ( text, label, values ) result (parse)
1508 character(len=*), intent(in) :: text !< The text string from which the values will be parsed.
1509 character(len=*), intent(in) :: label !< A label which describes the values being decoded.
1510 integer, intent(out) :: values(:) !< The value or values that have been decoded.
1511 
1512 include 'parse.inc'
1513 end function parse_integers
1514 
1515 function parse_strings ( text, label, values ) result (parse)
1516 character(len=*), intent(in) :: text !< The text string from which the values will be parsed.
1517 character(len=*), intent(in) :: label !< A label which describes the values being decoded.
1518 character(len=*), intent(out) :: values(:) !< The value or values that have been decoded.
1519 
1520 include 'parse.inc'
1521 end function parse_strings
1522 
1523 function parse_integer ( text, label, parse_ival ) result (parse)
1524 character(len=*), intent(in) :: text !< The text string from which the values will be parsed.
1525 character(len=*), intent(in) :: label !< A label which describes the values being decoded.
1526 integer, intent(out) :: parse_ival !< The value or values that have been decoded.
1527 integer :: parse
1528 
1529 integer :: values(1)
1530 
1531  parse = parse_integers( text, label, values )
1532  if (parse > 0) parse_ival = values(1)
1533 end function parse_integer
1534 
1535 function parse_string ( text, label, parse_sval ) result (parse)
1536 character(len=*), intent(in) :: text !< The text string from which the values will be parsed.
1537 character(len=*), intent(in) :: label !< A label which describes the values being decoded.
1538 character(len=*), intent(out) :: parse_sval !< The value or values that have been decoded.
1539 integer :: parse
1540 
1541 character(len=len(parse_sval)) :: values(1)
1542 
1543  parse = parse_strings( text, label, values )
1544  if (parse > 0) parse_sval = values(1)
1545 end function parse_string
1546 
1547 !> @brief A function to create a field as a child of parent_p. This will return
1548 !! a pointer to a field_def type.
1549 !!
1550 !> Allocate and initialize a new field in parent_p list.
1551 !! Return a pointer to the field on success, or a null pointer
1552 !! on failure.
1553 !! <br>Example usage:
1554 !! @code{.F90}
1555 !! list_p => create_field(parent_p, name)
1556 !! @endcode
1557 function create_field(parent_p, name) &
1558  result(list_p)
1559 type (field_def), pointer :: list_p
1560 type (field_def), pointer :: parent_p !< A pointer to the parent of the field that is to be created
1561 character(len=*), intent(in) :: name !< The name of the field that is to be created
1562 
1563 integer :: error, out_unit
1564 ! Check for fatal errors which should never arise
1565 out_unit = stdout()
1566 if (.not. associated(parent_p) .or. name .eq. ' ') then
1567  nullify(list_p)
1568  return
1569 endif
1570 
1571 ! Allocate space for the new list
1572 allocate(list_p, stat = error)
1573 if (error .ne. 0) then
1574  write (out_unit,*) trim(error_header), 'Error ', error, &
1575  ' allocating memory for list ', trim(name)
1576  nullify(list_p)
1577  return
1578 endif
1579 ! Initialize the new field
1580 list_p%name = name
1581 
1582 nullify(list_p%next)
1583 list_p%prev => parent_p%last_field
1584 nullify(list_p%first_field)
1585 nullify(list_p%last_field)
1586 list_p%length = 0
1587 list_p%field_type = null_type
1588 list_p%max_index = 0
1589 list_p%array_dim = 0
1590 if (allocated(list_p%i_value)) deallocate(list_p%i_value)
1591 if (allocated(list_p%l_value)) deallocate(list_p%l_value)
1592 if (allocated(list_p%r_value)) deallocate(list_p%r_value)
1593 if (allocated(list_p%s_value)) deallocate(list_p%s_value)
1594 ! If this is the first field in the parent, then set the pointer
1595 ! to it, otherwise, update the "next" pointer for the last list
1596 if (parent_p%length .le. 0) then
1597  parent_p%first_field => list_p
1598 else
1599  parent_p%last_field%next => list_p
1600 endif
1601 ! Update the pointer for the last list in the parent
1602 parent_p%last_field => list_p
1603 ! Update the length for the parent
1604 parent_p%length = parent_p%length + 1
1605 ! Set the new index as the return value
1606 list_p%index = parent_p%length
1607 ! set the pointer to the parent list
1608 list_p%parent => parent_p
1609 
1610 end function create_field
1611 
1612 !> @brief This is a function that lists the parameters of a field.
1613 !!
1614 !> Given a pointer to a list, this function prints out the fields, and
1615 !! subfields, if recursive is true, associated with the list.
1616 !!
1617 !! This is most likely to be used through fm_dump_list.
1618 !! <br> Example usage:
1619 !! @code{.F90}
1620 !! success = dump_list(list_p, recursive=.true., depth=0)
1621 !! @endcode
1622 logical recursive function dump_list(list_p, recursive, depth, out_unit) result(success)
1623 
1624  type (field_def), pointer :: list_p !< pointer to the field to be printed out
1625  logical, intent(in) :: recursive !< flag to make function recursively print subfields
1626  integer, intent(in) :: depth !< Listing will be padded so that 'depth' spaces appear before
1627  !! the field being printed
1628  integer, intent(in) :: out_unit !< unit number to print to
1629 
1630  integer :: depthp1
1631  integer :: j
1632  character(len=fm_field_name_len) :: num, scratch
1633  type (field_def), pointer :: this_field_p
1634  character(len=depth+fm_field_name_len) :: blank
1635 
1636  blank = ' ' ! initialize blank string
1637 
1638  ! Check for a valid list
1639  success = .false.
1640  if (.not. associated(list_p)) then
1641  return
1642  elseif (list_p%field_type .ne. list_type) then
1643  return
1644  endif
1645 
1646  ! set the default return value
1647  success = .true.
1648 
1649  ! Print the name of this list
1650  write (out_unit,'(a,a,a)') blank(1:depth), trim(list_p%name), list_sep
1651 
1652  ! Increment the indentation depth
1653  ! The following max function is to work around an error in the IBM compiler for len_trim
1654  ! depthp1 = depth + max(len_trim(list_p%name),0) + len_trim(list_sep)
1655  depthp1 = depth + 6
1656 
1657  this_field_p => list_p%first_field
1658 
1659  do while (associated(this_field_p))
1660 
1661  select case(this_field_p%field_type)
1662  case(list_type)
1663  ! If this is a list, then call dump_list
1664  if (recursive) then
1665  ! If recursive is true, then this routine will find and dump sub-fields.
1666  success = dump_list(this_field_p, .true., depthp1, out_unit)
1667  if (.not.success) exit ! quit immediately in case of error
1668  else ! Otherwise it will print out the name of this field.
1669  write (out_unit,'(a,a,a)') blank(1:depthp1), trim(this_field_p%name), list_sep
1670  endif
1671 
1672  case(integer_type)
1673  if (this_field_p%max_index .eq. 0) then
1674  write (out_unit,'(a,a,a)') blank(1:depthp1), trim(this_field_p%name), ' = NULL'
1675  elseif (this_field_p%max_index .eq. 1) then
1676  write (scratch,*) this_field_p%i_value(1)
1677  write (out_unit,'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), ' = ', &
1678  trim(adjustl(scratch))
1679  else ! Write out the array of values for this field.
1680  do j = 1, this_field_p%max_index
1681  write (scratch,*) this_field_p%i_value(j)
1682  write (num,*) j
1683  write (out_unit,'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1684  '[', trim(adjustl(num)), '] = ', trim(adjustl(scratch))
1685  enddo
1686  endif
1687 
1688  case(logical_type)
1689  if (this_field_p%max_index .eq. 0) then
1690  write (out_unit,'(a,a,a)') blank(1:depthp1), trim(this_field_p%name), ' = NULL'
1691  elseif (this_field_p%max_index .eq. 1) then
1692  write (scratch,'(l1)') this_field_p%l_value(1)
1693  write (out_unit,'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), ' = ', &
1694  trim(adjustl(scratch))
1695  else ! Write out the array of values for this field.
1696  do j = 1, this_field_p%max_index
1697  write (scratch,'(l1)') this_field_p%l_value(j)
1698  write (num,*) j
1699  write (out_unit,'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1700  '[', trim(adjustl(num)), '] = ', trim(adjustl(scratch))
1701  enddo
1702  endif
1703 
1704  case(real_type)
1705  if (this_field_p%max_index .eq. 0) then
1706  write (out_unit,'(a,a,a)') blank(1:depthp1), trim(this_field_p%name), ' = NULL'
1707  elseif (this_field_p%max_index .eq. 1) then
1708  write (scratch,*) this_field_p%r_value(1)
1709  write (out_unit,'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), ' = ', &
1710  trim(adjustl(scratch))
1711  else ! Write out the array of values for this field.
1712  do j = 1, this_field_p%max_index
1713  write (scratch,*) this_field_p%r_value(j)
1714  write (num,*) j
1715  write (out_unit,'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1716  '[', trim(adjustl(num)), '] = ', trim(adjustl(scratch))
1717  end do
1718  endif
1719 
1720  case(string_type)
1721  if (this_field_p%max_index .eq. 0) then
1722  write (out_unit,'(a,a,a)') blank(1:depthp1), trim(this_field_p%name), ' = NULL'
1723  elseif (this_field_p%max_index .eq. 1) then
1724  write (out_unit,'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), ' = ', &
1725  ''''//trim(this_field_p%s_value(1))//''''
1726  else ! Write out the array of values for this field.
1727  do j = 1, this_field_p%max_index
1728  write (num,*) j
1729  write (out_unit,'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1730  '[', trim(adjustl(num)), '] = ', ''''//trim(this_field_p%s_value(j))//''''
1731  enddo
1732  endif
1733 
1734  case default
1735  success = .false.
1736  exit
1737 
1738  end select
1739 
1740  this_field_p => this_field_p%next
1741  enddo
1742 
1743 end function dump_list
1744 
1745 !> @brief A subroutine that splits a listname into a path and a base.
1746 !!
1747 !> Find the base name for a list by splitting the list name into
1748 !! a path and base. The base is the last field within name, while the
1749 !! path is the preceding section of name. The base string can then be
1750 !! used to query for values associated with name.
1751 subroutine find_base(name, path, base)
1752 
1753 character(len=*), intent(in) :: name !< list name for a field
1754 character(len=*), intent(out) :: path !< path of the base field
1755 character(len=*), intent(out) :: base !< A string which can be used to query for values associated with name
1756 
1757 integer :: i
1758 integer :: length
1759 
1760 ! Check for the last occurrence of the list separator in name
1761 ! The following max function is to work around an error in the IBM compiler for len_trim
1762 length = max(len_trim(name),0)
1763 if (length .eq. 0) then
1764 
1765  ! Empty name, so return empty path and base
1766  path = ' '
1767  base = ' '
1768 else
1769  ! Remove trailing list separators
1770  do while (name(length:length) .eq. list_sep)
1771  length = length - 1
1772  if (length .eq. 0) then
1773  exit
1774  endif
1775  enddo
1776  if (length .eq. 0) then
1777 
1778  ! Name only list separators, so return empty path and base
1779  path = ' '
1780  base = ' '
1781  else
1782  ! Check for the last occurrence of the list separator in name
1783  i = index(name(1:length), list_sep, back = .true.)
1784  if (i .eq. 0) then
1785  ! no list separators in the path, so return an empty path
1786  ! and name as the base
1787  path = ' '
1788  base = name(1:length)
1789  else
1790  ! Found a list separator, so return the part up to the last
1791  ! list separator in path, and the remainder in base
1792  path = name(1:i)
1793  base = name(i+1:length)
1794  endif
1795  endif
1796 endif
1797 
1798 end subroutine find_base
1799 
1800 !> @brief Find and return a pointer to the field in the specified
1801 !! list. Return a null pointer on error.
1802 !!
1803 !> Find and return a pointer to the field in the specified
1804 !! list. Return a null pointer on error. Given a pointer to a field,
1805 !! this function searchs for "name" as a sub field.
1806 !> @returns A pointer to the field corresponding to "name" or an unassociated pointer if the field
1807 !! name does not exist.
1808 function find_field(name, this_list_p) &
1809  result(field_p)
1810 type (field_def), pointer :: field_p
1811 character(len=*), intent(in) :: name !< The name of a field that the user wishes to find
1812 type (field_def), pointer :: this_list_p !< A pointer to a list which the user wishes to search
1813  !! for a field "name".
1814 
1815 type (field_def), pointer, save :: temp_p
1816 
1817 
1818 nullify (field_p)
1819 
1820 if (name .eq. '.') then
1821 
1822 ! If the field is '.' then return this list
1823  field_p => this_list_p
1824 elseif (name .eq. '..') then
1825 ! If the field is '..' then return the parent list
1826  field_p => this_list_p%parent
1827 else
1828 ! Loop over each field in this list
1829  temp_p => this_list_p%first_field
1830 
1831  do while (associated(temp_p))
1832 ! If the name matches, then set the return pointer and exit
1833 ! the loop
1834  if (temp_p%name .eq. name) then
1835  field_p => temp_p
1836  exit
1837  endif
1838 
1839  temp_p => temp_p%next
1840 
1841  enddo
1842 endif
1843 
1844 end function find_field
1845 
1846 !> @brief Find the first list for a name by splitting the name into
1847 !! a head and the rest.
1848 !!
1849 !> Find the first list for a name by splitting the name into a head and the
1850 !! rest. The head is the first field within name, while rest is the remaining
1851 !! section of name. The head string can then be used to find other fields that
1852 !! may be associated with name.
1853 subroutine find_head(name, head, rest)
1854 
1855 character(len=*), intent(in) :: name !< The name of a field of interest
1856 character(len=*), intent(out) :: head !< the first field within name
1857 character(len=*), intent(out) :: rest !< the remaining section of name
1858 
1859 integer :: i
1860 ! Check for the first occurrence of the list separator in name
1861 i = index(name, list_sep)
1862 ! Check for additional consecutive list separators and return
1863 ! those also
1864 do while (i .le. len(name))
1865  if (name(i+1:i+1) .eq. list_sep) then
1866  i = i + 1
1867  else
1868  exit
1869  endif
1870 enddo
1871 
1872 if (i .eq. 0) then
1873 ! no list separators in the path, so return an empty head and
1874 ! name as the rest
1875  head = ' '
1876  rest = name
1877 elseif (i .eq. len(name)) then
1878 ! The last character in name is a list separator, so return name
1879 ! as head and an empty rest
1880  head = name
1881  rest = ' '
1882 else
1883 ! Found a list separator, so return the part up to the list
1884 ! separator in head, and the remainder in rest
1885  head = name(1:i)
1886  rest = name(i+1:)
1887 endif
1888 
1889 end subroutine find_head
1890 
1891 !> @brief Find and return a pointer to the specified list, relative to
1892 !! relative_p. Return a null pointer on error.
1893 !!
1894 !> This function, when supplied a pointer to a field and a name of a second
1895 !! field relative to that pointer, will find a list and return the pointer to
1896 !! the second field. If create is .true. and the second field does not exist,
1897 !! it will be created.
1898 !> @returns A pointer to the list to be returned
1899 function find_list(path, relative_p, create) &
1900  result(list_p)
1901 type (field_def), pointer :: list_p
1902 character(len=*), intent(in) :: path !< path to the list of interest
1903 type (field_def), pointer :: relative_p !< pointer to the list to which "path" is relative to
1904 logical, intent(in) :: create !< If the list does not exist, it will be created if set to true
1905 
1906 character(len=FMS_PATH_LEN) :: working_path
1907 character(len=FMS_PATH_LEN) :: rest
1908 character(len=fm_field_name_len) :: this_list
1909 integer :: i, out_unit
1910 type (field_def), pointer, save :: working_path_p
1911 type (field_def), pointer, save :: this_list_p
1912 
1913 out_unit = stdout()
1914 nullify(list_p)
1915 ! If the path is empty, then return the relative list
1916 if (path .eq. ' ') then
1917 
1918  list_p => relative_p
1919 
1920 else
1921 ! If a fully qualified path is given (i.e., starts with the
1922 ! list separator) then do everything relative to root,
1923 ! otherwise, do everything relative to relative list.
1924  if (path(1:1) .eq. list_sep) then
1925  working_path_p => root_p
1926  working_path = path(2:)
1927  else
1928  working_path_p => relative_p
1929  working_path = path
1930  endif
1931 ! Loop over each field in the path
1932  do while (working_path .ne. ' ')
1933 ! Get the first list in the working path
1934  call find_head(working_path, this_list, rest)
1935 ! If the first list is empty, then the 'rest' should hold the
1936 ! final field in the path
1937  if (this_list .eq. ' ') then
1938  this_list = rest
1939  rest = ' '
1940  endif
1941 ! Strip off trailing list separators
1942  i = len_trim(this_list)
1943  do while (i .gt. 0 .and. this_list(i:i) .eq. list_sep)
1944  this_list(i:i) = ' '
1945  i = i - 1
1946  enddo
1947 ! Find a pointer to this field in the working list
1948  this_list_p => find_field(this_list, working_path_p)
1949 
1950  if (.not. associated(this_list_p)) then
1951  if (create) then
1952 ! Create the list if so requested
1953  this_list_p => make_list(working_path_p, this_list)
1954  if (.not. associated(this_list_p)) then
1955  nullify(list_p)
1956  return
1957  endif
1958  else
1959 ! Otherwise, return an error
1960 
1961  nullify(list_p)
1962  return
1963  endif
1964  endif
1965 ! Make sure that the field found is a list, and if so, proceed to
1966 ! the next field in the path, otherwise, return an error
1967  if (this_list_p%field_type .eq. list_type) then
1968  working_path_p => this_list_p
1969  working_path = rest
1970  else
1971  nullify(list_p)
1972  return
1973  endif
1974  enddo
1975  list_p => working_path_p
1976 endif
1977 
1978 end function find_list
1979 
1980 !> @brief Change the current list. Return true on success, false otherwise
1981 !!
1982 !> This function changes the currect list to correspond to the list named name.
1983 !! If the first character of name is the list separator (/) then the list will
1984 !! search for "name" starting from the root of the field tree. Otherwise it
1985 !! will search for name starting from the current list.
1986 !! @return A flag to indicate operation success, true = no errors
1987 function fm_change_list(name) &
1988  result(success)
1989 logical :: success
1990 character(len=*), intent(in) :: name !< name of a list to change to
1991 
1992 type (field_def), pointer, save :: temp_p
1993 ! Initialize the field manager if needed
1994 if (.not. module_is_initialized) then
1996 endif
1997 ! Find the list if path is not empty
1998 temp_p => find_list(name, current_list_p, .false.)
1999 
2000 if (associated(temp_p)) then
2001  current_list_p => temp_p
2002  success = .true.
2003 else
2004  success = .false.
2005 endif
2006 
2007 end function fm_change_list
2008 
2009 !> @brief Change the root list
2010 !!
2011 !> This function changes the root of the field tree to correspond to the
2012 !! field named name. An example of a use of this would be if code is
2013 !! interested in a subset of fields with a common base. This common base
2014 !! could be set using fm_change_root and fields could be referenced using
2015 !! this root.
2016 !!
2017 !! This function should be used in conjunction with fm_return_root.
2018 !! @return A flag to indicate operation success, true = no errors
2019 function fm_change_root(name) &
2020  result(success)
2021 logical :: success
2022 character(len=*), intent(in) :: name !< name of the field which the user wishes to become the root.
2023 
2024 type (field_def), pointer, save :: temp_list_p
2025 integer :: out_unit
2026 ! Initialize the field manager if needed
2027 if (.not. module_is_initialized) then
2029 endif
2030 out_unit = stdout()
2031 ! Must supply a field field name
2032 if (name .eq. ' ') then
2033  success = .false.
2034  return
2035 endif
2036 ! Get a pointer to the list
2037 temp_list_p => find_list(name, current_list_p, .false.)
2038 
2039 if (associated(temp_list_p)) then
2040 ! restore the saved root values if we've already changed root
2041  if (save_root_name .ne. ' ') then
2042  root_p%name = save_root_name
2043  root_p%parent => save_root_parent_p
2044  endif
2045 ! set the pointer for the new root field
2046  root_p => temp_list_p
2047 ! save the new root field's name and parent
2048  save_root_name = root_p%name
2049  save_root_parent_p => root_p%parent
2050 ! set the new root name and parent fields to appropriate values
2051  root_p%name = ' '
2052  nullify(root_p%parent)
2053 ! set the current list to the new root as it likely is not
2054 ! going to be meaningful anymore
2055  current_list_p => root_p
2056  success = .true.
2057 else
2058 ! Couldn't find the list
2059  success = .false.
2060 endif
2061 
2062 end function fm_change_root
2063 
2064 !> @brief A function to list properties associated with a field.
2065 !!
2066 !> This function writes the contents of the field named "name" to stdout.
2067 !! If recursive is present and .true., then this function writes out the
2068 !! contents of any subfields associated with the field named "name".
2069 !! @return A flag to indicate operation success, true = no errors
2070 logical function fm_dump_list(name, recursive, unit) result (success)
2071  character(len=*), intent(in) :: name !< The name of the field for which output is requested.
2072  logical, intent(in), optional :: recursive !< If present and .true., then a recursive listing of
2073  !! fields will be performed.
2074  integer, intent(in), optional :: unit !< file to print to
2075 
2076  logical :: recursive_t
2077  type (field_def), pointer, save :: temp_list_p
2078  integer :: out_unit
2079 
2080  if (present(unit)) then
2081  out_unit = unit
2082  else
2083  out_unit = stdout()
2084  endif
2085 
2086  recursive_t = .false.
2087  if (present(recursive)) recursive_t = recursive
2088  if (.not. module_is_initialized) call initialize_module_variables()
2089 
2090  if (name .eq. ' ') then
2091  ! If list is empty, then dump the current list
2092  temp_list_p => current_list_p
2093  success = .true.
2094  else
2095  ! Get a pointer to the list
2096  temp_list_p => find_list(name, current_list_p, .false.)
2097  if (associated(temp_list_p)) then
2098  success = .true.
2099  else
2100  success = .false.
2101  endif
2102  endif
2103  ! Dump the list
2104  if (success) then
2105  success = dump_list(temp_list_p, recursive_t, 0, out_unit)
2106  endif
2107 end function fm_dump_list
2108 
2109 !> @brief A function to test whether a named field exists.
2110 !!
2111 !> This function determines is a field exists, relative to the current list,
2112 !! and returns true if the list exists, false otherwise.
2113 !! @return A flag to indicate operation success, true = no errors
2114 function fm_exists(name) &
2115  result(success)
2116 logical :: success
2117 character(len=*), intent(in) :: name !< The name of the field that is being queried
2118 
2119 type (field_def), pointer, save :: dummy_p
2120 ! Initialize the field manager if needed
2121 if (.not. module_is_initialized) then
2123 endif
2124 ! Determine whether the field exists
2125 dummy_p => get_field(name, current_list_p)
2126 success = associated(dummy_p)
2127 
2128 end function fm_exists
2129 
2130 !> @brief A function to return the index of a named field.
2131 !!
2132 !> Returns the index for name, returns the parameter NO_FIELD if it does not
2133 !! exist. If the first character of the named field is the list peparator,
2134 !! then the named field will be relative to the root of the field tree.
2135 !! Otherwise the named field will be relative to the current list.
2136 !> @returns index of the named field if it exists, otherwise the parameter NO_FIELD
2137 function fm_get_index(name) &
2138  result(index)
2139 integer :: index
2140 character(len=*), intent(in) :: name !< The name of a field that the user wishes to get an index for
2141 
2142 type (field_def), pointer, save :: temp_field_p
2143 integer :: out_unit
2144 
2145 out_unit = stdout()
2146 ! Initialize the field manager if needed
2147 if (.not. module_is_initialized) then
2149 endif
2150 ! Must supply a field field name
2151 if (name .eq. ' ') then
2152  index = no_field
2153  return
2154 endif
2155 ! Get a pointer to the field
2156 temp_field_p => get_field(name, current_list_p)
2157 if (associated(temp_field_p)) then
2158 ! Set the index
2159  index = temp_field_p%index
2160 else
2161  index = no_field
2162 endif
2163 
2164 end function fm_get_index
2165 
2166 !> @brief A function to return the full path of the current list.
2167 !!
2168 !> This function returns the full path for the current list. A blank
2169 !! path indicates an error condition has occurred.
2170 !> @returns The path corresponding to the current list
2172  result(path)
2173 character(len=FMS_PATH_LEN) :: path
2174 
2175 type (field_def), pointer, save :: temp_list_p
2176 ! Initialize the field manager if needed
2177 if (.not. module_is_initialized) then
2179 endif
2180 ! Set a pointer to the current list and proceed
2181 ! up the tree, filling in the name as we go
2182 temp_list_p => current_list_p
2183 path = ' '
2184 
2185 do while (associated(temp_list_p))
2186 ! Check whether we are at the root field--it is the
2187 ! only field with a blank name
2188  if (temp_list_p%name .eq. ' ') then
2189  exit
2190  endif
2191 ! Append the name to the path
2192  path = list_sep // trim(temp_list_p%name) // path
2193 ! Point to the next field
2194  temp_list_p => temp_list_p%parent
2195 enddo
2196 
2197 if (.not. associated(temp_list_p)) then
2198 ! The pointer is not associated, indicating an error has
2199 ! occurred, so set the path accordingly
2200  path = ' '
2201 elseif (path .eq. ' ') then
2202 ! If path is empty, then the current list must be root,
2203 ! so set path accordingly
2204  path = list_sep
2205 endif
2206 
2207 end function fm_get_current_list
2208 
2209 !> @brief A function to return how many elements are contained within the named
2210 !! list or entry.
2211 !!
2212 !> This function returns the list or entry length for the named list or entry.
2213 !! If the named field or entry does not exist, a value of 0 is returned.
2214 !> @returns The number of elements that the field name has.
2215 function fm_get_length(name) &
2216  result(length)
2217 integer :: length
2218 character(len=*), intent(in) :: name !< The name of a list or entry that the user wishes to get the length of
2219 
2220 type (field_def), pointer, save :: temp_field_p
2221 integer :: out_unit
2222 
2223 out_unit = stdout()
2224 ! Initialize the field manager if needed
2225 if (.not. module_is_initialized) then
2227 endif
2228 ! Must supply a field name
2229 if (name .eq. ' ') then
2230  length = 0
2231  return
2232 endif
2233 ! Get a pointer to the field
2234 temp_field_p => get_field(name, current_list_p)
2235 
2236 if (associated(temp_field_p)) then
2237 ! Set the field length
2238  if (temp_field_p%field_type .eq. list_type) then
2239  length = temp_field_p%length
2240  else
2241  length = temp_field_p%max_index
2242  endif
2243 else
2244  length = 0
2245 endif
2246 
2247 end function fm_get_length
2248 
2249 !> @brief A function to return the type of the named field
2250 !!
2251 !> This function returns the type of the field for name.
2252 !! This indicates whether the named field is a "list" (has children fields),
2253 !! or has values of type "integer", "real", "logical" or "string".
2254 !! If it does not exist it returns a blank string.
2255 !> @returns A string containing the type of the named field
2256 function fm_get_type(name) &
2257  result(name_field_type)
2258 character(len=8) :: name_field_type
2259 character(len=*), intent(in) :: name !< The name of a field that the user wishes to find the type of
2260 
2261 type (field_def), pointer, save :: temp_field_p
2262 integer :: out_unit
2263 
2264 out_unit = stdout()
2265 ! Initialize the field manager if needed
2266 if (.not. module_is_initialized) then
2268 endif
2269 ! Must supply a field name
2270 if (name .eq. ' ') then
2271  name_field_type = ' '
2272  return
2273 endif
2274 ! Get a pointer to the field
2275 temp_field_p => get_field(name, current_list_p)
2276 
2277 if (associated(temp_field_p)) then
2278 ! Set the field type
2279  name_field_type = field_type_name(temp_field_p%field_type)
2280 else
2281  name_field_type = ' '
2282 endif
2283 
2284 end function fm_get_type
2285 
2286 !> @returns A flag to indicate whether the function operated with (false) or without
2287 !! (true) errors.
2288 function fm_get_value_integer(name, get_ival, index) &
2289  result(success)
2290 logical :: success
2291 character(len=*), intent(in) :: name !< The name of a field that the user wishes to get a value for.
2292 integer, intent(out) :: get_ival !< The value associated with the named field.
2293 integer, intent(in), optional :: index !< An optional index to retrieve a single value from an array.
2294 
2295 integer :: index_t
2296 type (field_def), pointer, save :: temp_field_p
2297 integer :: out_unit
2298 
2299 out_unit = stdout()
2300 ! Initialize the field manager if needed
2301 if (.not. module_is_initialized) then
2303 endif
2304 ! Must supply a field field name
2305 if (name .eq. ' ') then
2306  get_ival = 0
2307  success = .false.
2308  return
2309 endif
2310 ! Set index to retrieve
2311 if (present(index)) then
2312  index_t = index
2313 else
2314  index_t = 1
2315 endif
2316 ! Get a pointer to the field
2317 temp_field_p => get_field(name, current_list_p)
2318 
2319 if (associated(temp_field_p)) then
2320 ! check that the field is the correct type
2321  if (temp_field_p%field_type .eq. integer_type) then
2322  if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index) then
2323 ! Index is not positive or index too large
2324  get_ival = 0
2325  success = .false.
2326  else
2327 ! extract the value
2328  get_ival = temp_field_p%i_value(index_t)
2329  success = .true.
2330  endif
2331  else
2332 ! Field not corrcet type
2333  get_ival = 0
2334  success = .false.
2335  endif
2336 else
2337  get_ival = 0
2338  success = .false.
2339 endif
2340 
2341 end function fm_get_value_integer
2342 
2343 !> @returns A flag to indicate whether the function operated with (false) or without
2344 !! (true) errors.
2345 function fm_get_value_logical(name, get_lval, index) &
2346  result(success)
2347 logical :: success
2348 character(len=*), intent(in) :: name !< The name of a field that the user wishes to get a value for.
2349 logical, intent(out) :: get_lval !< The value associated with the named field
2350 integer, intent(in), optional :: index !< An optional index to retrieve a single value from an array.
2351 
2352 integer :: index_t
2353 type (field_def), pointer, save :: temp_field_p
2354 integer :: out_unit
2355 
2356 out_unit = stdout()
2357 ! Initialize the field manager if needed
2358 if (.not. module_is_initialized) then
2360 endif
2361 ! Must supply a field field name
2362 if (name .eq. ' ') then
2363  get_lval = .false.
2364  success = .false.
2365  return
2366 endif
2367 ! Set index to retrieve
2368 if (present(index)) then
2369  index_t = index
2370 else
2371  index_t = 1
2372 endif
2373 ! Get a pointer to the field
2374 temp_field_p => get_field(name, current_list_p)
2375 
2376 if (associated(temp_field_p)) then
2377 ! check that the field is the correct type
2378  if (temp_field_p%field_type .eq. logical_type) then
2379 
2380  if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index) then
2381 ! Index is not positive or too large
2382  get_lval = .false.
2383  success = .false.
2384  else
2385 ! extract the value
2386  get_lval = temp_field_p%l_value(index_t)
2387  success = .true.
2388  endif
2389  else
2390 ! Field not correct type
2391  get_lval = .false.
2392  success = .false.
2393  endif
2394 else
2395  get_lval = .false.
2396  success = .false.
2397 endif
2398 
2399 end function fm_get_value_logical
2400 
2401 !> @returns A flag to indicate whether the function operated with (false) or without
2402 !! (true) errors.
2403 function fm_get_value_string(name, get_sval, index) &
2404  result(success)
2405 logical :: success
2406 character(len=*), intent(in) :: name !< The name of a field that the user wishes to get a value for.
2407 character(len=*), intent(out) :: get_sval !< The value associated with the named field
2408 integer, intent(in), optional :: index !< An optional index to retrieve a single value from an array.
2409 
2410 integer :: index_t
2411 type (field_def), pointer, save :: temp_field_p
2412 integer :: out_unit
2413 
2414 out_unit = stdout()
2415 ! Initialize the field manager if needed
2416 if (.not. module_is_initialized) then
2418 endif
2419 ! Must supply a field field name
2420 if (name .eq. ' ') then
2421  get_sval = ''
2422  success = .false.
2423  return
2424 endif
2425 ! Set index to retrieve
2426 if (present(index)) then
2427  index_t = index
2428 else
2429  index_t = 1
2430 endif
2431 ! Get a pointer to the field
2432 temp_field_p => get_field(name, current_list_p)
2433 
2434 if (associated(temp_field_p)) then
2435 ! check that the field is the correct type
2436  if (temp_field_p%field_type .eq. string_type) then
2437  if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index) then
2438 ! Index is not positive or is too large
2439  get_sval = ''
2440  success = .false.
2441  else
2442 ! extract the value
2443  get_sval = temp_field_p%s_value(index_t)
2444  success = .true.
2445  endif
2446  else
2447 ! Field not correct type
2448  get_sval = ''
2449  success = .false.
2450  endif
2451 else
2452  get_sval = ''
2453  success = .false.
2454 endif
2455 
2456 end function fm_get_value_string
2457 
2458 !> Iterates through the given list
2459 !> @returns A flag to indicate whether the function operated with (FALSE)
2460 !! or without (TRUE) errors
2461 function fm_loop_over_list_old(list, name, field_type, index) &
2462  result(success)
2463 logical :: success
2464 character(len=*), intent(in) :: list !< Name of a list to loop over
2465 character(len=*), intent(out) :: name !< name of a field from list
2466 character(len=fm_type_name_len), intent(out) :: field_type !< type of a list entry
2467 integer, intent(out) :: index !< index of the field within the list
2468 
2469 integer :: out_unit
2470 
2471 out_unit = stdout()
2472 ! Initialize the field manager if needed
2473 if (.not. module_is_initialized) then
2475 endif
2476 
2477 if (list .eq. loop_list .and. associated(loop_list_p)) then
2478 ! We've already started this loop, so continue on
2479  loop_list_p => loop_list_p%next
2480  success = set_list_stuff()
2481 elseif (list .eq. ' ') then
2482 ! If list is empty, then loop over the current list
2483  loop_list = ' '
2484  loop_list_p => current_list_p%first_field
2485  success = set_list_stuff()
2486 else
2487 ! Get a pointer to the list
2488  loop_list = list
2489  loop_list_p => find_list(loop_list, current_list_p, .false.)
2490  if (associated(loop_list_p)) then
2491  loop_list_p => loop_list_p%first_field
2492  success = set_list_stuff()
2493  else
2494  success = .false.
2495  endif
2496 endif
2497 
2498 return
2499 
2500 contains
2501 
2502 !> If the pointer matches to the right list,
2503 !! extract the field information. Used in fm_loop_over_list
2504 !> @returns A flag to indicate whether the function operated with (FALSE)
2505 !! or without (TRUE) errors
2506 function set_list_stuff() &
2507  result(success)
2508 
2509  logical :: success
2510 
2511  if (associated(loop_list_p)) then
2512  name = loop_list_p%name
2513  field_type = field_type_name(loop_list_p%field_type)
2514  index = loop_list_p%index
2515  success = .true.
2516  else
2517  name = ' '
2518  field_type = ' '
2519  index = 0
2520  success = .false.
2521  loop_list = ' '
2522  endif
2523 
2524 end function set_list_stuff
2525 
2526 end function fm_loop_over_list_old
2527 
2528 !> given a name of the list, prepares an iterator over the list content.
2529 !! If the name of the given list is blank, then the current list is used
2530 subroutine fm_init_loop(loop_list, iter)
2531  character(len=*) , intent(in) :: loop_list !< name of the list to iterate over
2532  type(fm_list_iter_type), intent(out) :: iter !< loop iterator
2533 
2534  if (.not.module_is_initialized) call initialize_module_variables
2535 
2536  if (loop_list==' ') then ! looping over current list
2537  iter%ptr => current_list_p%first_field
2538  else
2539  iter%ptr => find_list(loop_list,current_list_p,.false.)
2540  if (associated(iter%ptr)) iter%ptr => iter%ptr%first_field
2541  endif
2542 end subroutine fm_init_loop
2543 
2544 !> given a list iterator, returns information about curren list element
2545 !! and advances the iterator to the next list element. At the end of the
2546 !! list, returns FALSE
2547 function fm_loop_over_list_new(iter, name, field_type, index) &
2548  result(success) ; logical success
2549  type (fm_list_iter_type), intent(inout) :: iter !< list iterator
2550  character(len=*), intent(out) :: name !< name of the current list item
2551  character(len=*), intent(out) :: field_type !< type of the field
2552  integer , intent(out) :: index !< index in the list
2553 
2554  if (.not.module_is_initialized) call initialize_module_variables
2555  if (associated(iter%ptr)) then
2556  name = iter%ptr%name
2557  field_type = field_type_name(iter%ptr%field_type)
2558  index = iter%ptr%index
2559  success = .true.
2560  iter%ptr => iter%ptr%next
2561  else
2562  name = ' '
2563  field_type = ' '
2564  index = 0
2565  success = .false.
2566  endif
2567 end function fm_loop_over_list_new
2568 
2569 !> @brief A function to create a new list
2570 !!
2571 !> Allocate and initialize a new list and return the index of the list. If an
2572 !! error occurs return the parameter NO_FIELD.
2573 !> @return integer index of the newly created list
2574 function fm_new_list(name, create, keep) &
2575  result(index)
2576 integer :: index
2577 character(len=*), intent(in) :: name !< Name of a list that user wishes to create
2578 logical, intent(in), optional :: create !< If present and true, create the list if it does not exist
2579 logical, intent(in), optional :: keep !< If present and true, make this list the current list
2580 
2581 logical :: create_t
2582 logical :: keep_t
2583 character(len=FMS_PATH_LEN) :: path
2584 character(len=fm_field_name_len) :: base
2585 type (field_def), pointer, save :: temp_list_p
2586 integer :: out_unit
2587 
2588 out_unit = stdout()
2589 ! Initialize the field manager if needed
2590 if (.not. module_is_initialized) then
2592 endif
2593 ! Must supply a field list name
2594 if (name .eq. ' ') then
2595  index = no_field
2596  return
2597 endif
2598 ! Check for optional arguments
2599 if (present(create)) then
2600  create_t = create
2601 else
2602  create_t = .false.
2603 endif
2604 
2605 if (present(keep)) then
2606  keep_t = keep
2607 else
2608  keep_t = .false.
2609 endif
2610 ! Get a pointer to the parent list
2611 call find_base(name, path, base)
2612 
2613 temp_list_p => find_list(path, current_list_p, create_t)
2614 
2615 if (associated(temp_list_p)) then
2616 ! Create the list
2617  temp_list_p => make_list(temp_list_p, base)
2618  if (associated(temp_list_p)) then
2619 ! Make this list the current list, if requested
2620  if (keep_t) then
2621  current_list_p => temp_list_p
2622  endif
2623  index = temp_list_p%index
2624  else
2625  index = no_field
2626  endif
2627 else
2628  index = no_field
2629 endif
2630 
2631 end function fm_new_list
2632 
2633 !> @brief Assigns a given value to a given field
2634 !> @returns An index for the named field
2635 function fm_new_value_integer(name, new_ival, create, index, append) &
2636  result(field_index)
2637 integer :: field_index
2638 character(len=*), intent(in) :: name !< The name of a field that the user wishes to create
2639  !! a value for.
2640 integer, intent(in) :: new_ival !< The value that the user wishes to apply to the
2641  !! named field.
2642 logical, intent(in), optional :: create !< If present and .true., then a value for this
2643  !! field will be created.
2644 integer, intent(in), optional :: index !< The index to an array of values that the user
2645  !! wishes to apply a new value.
2646 logical, intent(in), optional :: append !< If present and .true., then append the value to
2647  !! an array of the present values. If present and .true., then index cannot be greater than 0.
2648 
2649 logical :: create_t
2650 integer :: i
2651 integer :: index_t
2652 integer, pointer, dimension(:) :: temp_i_value
2653 character(len=FMS_PATH_LEN) :: path
2654 character(len=fm_field_name_len) :: base
2655 type (field_def), pointer, save :: temp_list_p
2656 type (field_def), pointer, save :: temp_field_p
2657 integer :: out_unit
2658 
2659 out_unit = stdout()
2660 ! Initialize the field manager if needed
2661 if (.not. module_is_initialized) then
2663 endif
2664 ! Must supply a field name
2665 if (name .eq. ' ') then
2666  field_index = no_field
2667  return
2668 endif
2669 ! Check for optional arguments
2670 if (present(create)) then
2671  create_t = create
2672 else
2673  create_t = .false.
2674 endif
2675 ! Check that append is not true and index non-positive
2676 if (present(index) .and. present(append)) then
2677  if (append .and. index .gt. 0) then
2678  field_index = no_field
2679  return
2680  endif
2681 endif
2682 ! Set index to define
2683 if (present(index)) then
2684  index_t = index
2685  if (index_t .lt. 0) then
2686 ! Index is negative
2687  field_index = no_field
2688  return
2689  endif
2690 else
2691  index_t = 1
2692 endif
2693 ! Get a pointer to the parent list
2694 call find_base(name, path, base)
2695 temp_list_p => find_list(path, current_list_p, create_t)
2696 
2697 if (associated(temp_list_p)) then
2698  temp_field_p => find_field(base, temp_list_p)
2699  if (.not. associated(temp_field_p)) then
2700 ! Create the field if it doesn't exist
2701  temp_field_p => create_field(temp_list_p, base)
2702  endif
2703  if (associated(temp_field_p)) then
2704 ! Check if the field_type is the same as previously
2705 ! If not then reset max_index to 0
2706  if (temp_field_p%field_type == real_type ) then
2707  ! promote integer input to real
2708  ! all real field values are stored as r8_kind
2709  field_index = fm_new_value(name, real(new_ival,r8_kind), create, index, append)
2710  return
2711  else if (temp_field_p%field_type /= integer_type ) then
2712  ! slm: why would we reset index? Is it not an error to have a "list" defined
2713  ! with different types in more than one place?
2714  temp_field_p%max_index = 0
2715  endif
2716 ! Assign the type
2717  temp_field_p%field_type = integer_type
2718 ! Set the index if appending
2719  if (present(append)) then
2720  if (append) then
2721  index_t = temp_field_p%max_index + 1
2722  endif
2723  endif
2724 
2725  if (index_t .gt. temp_field_p%max_index + 1) then
2726 ! Index too large
2727  field_index = no_field
2728  return
2729 
2730  elseif (index_t .eq. 0 .and. &
2731  temp_field_p%max_index .gt. 0) then
2732 ! Can't set non-null field to null
2733  field_index = no_field
2734  return
2735 
2736  elseif (.not. allocated(temp_field_p%i_value) .and. &
2737  index_t .gt. 0) then
2738 ! Array undefined, so allocate the array
2739  allocate(temp_field_p%i_value(1))
2740  temp_field_p%max_index = 1
2741  temp_field_p%array_dim = 1
2742  elseif (index_t .gt. temp_field_p%array_dim) then
2743 ! Array is too small, so allocate new array and copy over
2744 ! old values
2745  temp_field_p%array_dim = temp_field_p%array_dim + array_increment
2746  allocate (temp_i_value(temp_field_p%array_dim))
2747  do i = 1, temp_field_p%max_index
2748  temp_i_value(i) = temp_field_p%i_value(i)
2749  enddo
2750  if (allocated(temp_field_p%i_value)) deallocate(temp_field_p%i_value)
2751  temp_field_p%i_value = temp_i_value
2752  temp_field_p%max_index = index_t
2753  endif
2754 ! Assign the value and set the field_index for return
2755 ! for non-null fields (index_t > 0)
2756  if (index_t .gt. 0) then
2757  temp_field_p%i_value(index_t) = new_ival
2758  if (index_t .gt. temp_field_p%max_index) then
2759  temp_field_p%max_index = index_t
2760  endif
2761  endif
2762  field_index = temp_field_p%index
2763 
2764  else
2765  field_index = no_field
2766  endif
2767 else
2768  field_index = no_field
2769 endif
2770 
2771 end function fm_new_value_integer
2772 
2773 !> @brief Assigns a given value to a given field
2774 !> @returns An index for the named field
2775 function fm_new_value_logical(name, new_lval, create, index, append) &
2776  result(field_index)
2777 integer :: field_index
2778 character(len=*), intent(in) :: name !< The name of a field that the user wishes to create
2779  !! a value for.
2780 logical, intent(in) :: new_lval !< The value that the user wishes to apply to the
2781  !! named field.
2782 logical, intent(in), optional :: create !< If present and .true., then a value for this
2783  !! field will be created.
2784 integer, intent(in), optional :: index !< The index to an array of values that the user
2785  !! wishes to apply a new value.
2786 logical, intent(in), optional :: append !< If present and .true., then append the value to
2787  !! an array of the present values. If present and .true., then index cannot be greater than 0.
2788 
2789 character(len=FMS_PATH_LEN) :: path
2790 character(len=fm_field_name_len) :: base
2791 integer :: i
2792 integer :: index_t
2793 logical :: create_t
2794 logical, dimension(:), pointer :: temp_l_value
2795 type (field_def), pointer, save :: temp_list_p
2796 type (field_def), pointer, save :: temp_field_p
2797 integer :: out_unit
2798 
2799 out_unit = stdout()
2800 ! Initialize the field manager if needed
2801 if (.not. module_is_initialized) then
2803 endif
2804 ! Must supply a field name
2805 if (name .eq. ' ') then
2806  field_index = no_field
2807  return
2808 endif
2809 ! Check for optional arguments
2810 if (present(create)) then
2811  create_t = create
2812 else
2813  create_t = .false.
2814 endif
2815 ! Check that append is not true and index greater than 0
2816 if (present(index) .and. present(append)) then
2817  if (append .and. index .gt. 0) then
2818  field_index = no_field
2819  return
2820  endif
2821 endif
2822 ! Set index to define
2823 if (present(index)) then
2824  index_t = index
2825  if (index_t .lt. 0) then
2826 ! Index is negative
2827  field_index = no_field
2828  return
2829  endif
2830 else
2831  index_t = 1
2832 endif
2833 ! Get a pointer to the parent list
2834 call find_base(name, path, base)
2835 temp_list_p => find_list(path, current_list_p, create_t)
2836 
2837 if (associated(temp_list_p)) then
2838  temp_field_p => find_field(base, temp_list_p)
2839  if (.not. associated(temp_field_p)) then
2840 ! Create the field if it doesn't exist
2841  temp_field_p => create_field(temp_list_p, base)
2842  endif
2843  if (associated(temp_field_p)) then
2844 ! Check if the field_type is the same as previously
2845 ! If not then reset max_index to 0
2846  if (temp_field_p%field_type /= logical_type ) then
2847  temp_field_p%max_index = 0
2848  endif
2849 ! Assign the type
2850  temp_field_p%field_type = logical_type
2851 ! Set the index if appending
2852  if (present(append)) then
2853  if (append) then
2854  index_t = temp_field_p%max_index + 1
2855  endif
2856  endif
2857 
2858  if (index_t .gt. temp_field_p%max_index + 1) then
2859 ! Index too large
2860  field_index = no_field
2861  return
2862 
2863  elseif (index_t .eq. 0 .and. &
2864  temp_field_p%max_index .gt. 0) then
2865 ! Can't set non-null field to null
2866  field_index = no_field
2867  return
2868 
2869  elseif (.not. allocated(temp_field_p%l_value) .and. &
2870  index_t .gt. 0) then
2871 ! Array undefined, so allocate the array
2872  allocate(temp_field_p%l_value(1))
2873  temp_field_p%max_index = 1
2874  temp_field_p%array_dim = 1
2875 
2876  elseif (index_t .gt. temp_field_p%array_dim) then
2877 ! Array is too small, so allocate new array and copy over
2878 ! old values
2879  temp_field_p%array_dim = temp_field_p%array_dim + array_increment
2880  allocate (temp_l_value(temp_field_p%array_dim))
2881  do i = 1, temp_field_p%max_index
2882  temp_l_value(i) = temp_field_p%l_value(i)
2883  enddo
2884  if (allocated(temp_field_p%l_value)) deallocate(temp_field_p%l_value)
2885  temp_field_p%l_value = temp_l_value
2886  temp_field_p%max_index = index_t
2887 
2888  endif
2889 ! Assign the value and set the field_index for return
2890 ! for non-null fields (index_t > 0)
2891  if (index_t .gt. 0) then
2892  temp_field_p%l_value(index_t) = new_lval
2893  if (index_t .gt. temp_field_p%max_index) then
2894  temp_field_p%max_index = index_t
2895  endif
2896  endif
2897  field_index = temp_field_p%index
2898  else
2899  field_index = no_field
2900  endif
2901 else
2902  field_index = no_field
2903 endif
2904 
2905 end function fm_new_value_logical
2906 
2907 !> @brief Assigns a given value to a given field
2908 !> @returns An index for the named field
2909 function fm_new_value_string(name, new_sval, create, index, append) &
2910  result(field_index)
2911 integer :: field_index
2912 character(len=*), intent(in) :: name !< The name of a field that the user wishes to create
2913  !! a value for.
2914 character(len=*), intent(in) :: new_sval !< The value that the user wishes to apply to the
2915  !! named field.
2916 logical, intent(in), optional :: create !< If present and .true., then a value for this
2917  !! field will be created.
2918 integer, intent(in), optional :: index !< The index to an array of values that the user
2919  !! wishes to apply a new value.
2920 logical, intent(in), optional :: append !< If present and .true., then append the value to
2921 
2922 character(len=fm_string_len), dimension(:), pointer :: temp_s_value
2923 character(len=FMS_PATH_LEN) :: path
2924 character(len=fm_field_name_len) :: base
2925 integer :: i
2926 integer :: index_t
2927 logical :: create_t
2928 type (field_def), save, pointer :: temp_list_p
2929 type (field_def), save, pointer :: temp_field_p
2930 integer :: out_unit
2931 
2932 out_unit = stdout()
2933 ! Initialize the field manager if needed
2934 if (.not. module_is_initialized) then
2936 endif
2937 ! Must supply a field name
2938 if (name .eq. ' ') then
2939  field_index = no_field
2940  return
2941 endif
2942 ! Check for optional arguments
2943 if (present(create)) then
2944  create_t = create
2945 else
2946  create_t = .false.
2947 endif
2948 ! Check that append is not true and index greater than 0
2949 if (present(index) .and. present(append)) then
2950  if (append .and. index .gt. 0) then
2951  field_index = no_field
2952  return
2953  endif
2954 endif
2955 ! Set index to define
2956 if (present(index)) then
2957  index_t = index
2958  if (index_t .lt. 0) then
2959 ! Index is negative
2960  field_index = no_field
2961  return
2962  endif
2963 else
2964  index_t = 1
2965 endif
2966 ! Get a pointer to the parent list
2967 call find_base(name, path, base)
2968 temp_list_p => find_list(path, current_list_p, create_t)
2969 
2970 if (associated(temp_list_p)) then
2971  temp_field_p => find_field(base, temp_list_p)
2972  if (.not. associated(temp_field_p)) then
2973 ! Create the field if it doesn't exist
2974  temp_field_p => create_field(temp_list_p, base)
2975  endif
2976  if (associated(temp_field_p)) then
2977 ! Check if the field_type is the same as previously
2978 ! If not then reset max_index to 0
2979  if (temp_field_p%field_type /= string_type ) then
2980  temp_field_p%max_index = 0
2981  endif
2982 ! Assign the type
2983  temp_field_p%field_type = string_type
2984 ! Set the index if appending
2985  if (present(append)) then
2986  if (append) then
2987  index_t = temp_field_p%max_index + 1
2988  endif
2989  endif
2990 
2991  if (index_t .gt. temp_field_p%max_index + 1) then
2992 ! Index too large
2993  field_index = no_field
2994  return
2995 
2996  elseif (index_t .eq. 0 .and. &
2997  temp_field_p%max_index .gt. 0) then
2998 ! Can't set non-null field to null
2999  field_index = no_field
3000  return
3001 
3002  elseif (.not.allocated(temp_field_p%s_value) .and. &
3003  index_t .gt. 0) then
3004 ! Array undefined, so allocate the array
3005  allocate(temp_field_p%s_value(1))
3006  temp_field_p%max_index = 1
3007  temp_field_p%array_dim = 1
3008 
3009  elseif (index_t .gt. temp_field_p%array_dim) then
3010 ! Array is too small, so allocate new array and copy over
3011 ! old values
3012  temp_field_p%array_dim = temp_field_p%array_dim + array_increment
3013  allocate (temp_s_value(temp_field_p%array_dim))
3014  do i = 1, temp_field_p%max_index
3015  temp_s_value(i) = temp_field_p%s_value(i)
3016  enddo
3017  if (allocated(temp_field_p%s_value)) deallocate(temp_field_p%s_value)
3018  temp_field_p%s_value = temp_s_value
3019  temp_field_p%max_index = index_t
3020 
3021  endif
3022 ! Assign the value and set the field_index for return
3023 ! for non-null fields (index_t > 0)
3024  if (index_t .gt. 0) then
3025  temp_field_p%s_value(index_t) = new_sval
3026  if (index_t .gt. temp_field_p%max_index) then
3027  temp_field_p%max_index = index_t
3028  endif
3029  endif
3030  field_index = temp_field_p%index
3031  else
3032 ! Error in making the field
3033  field_index = no_field
3034  endif
3035 else
3036 ! Error following the path
3037  field_index = no_field
3038 endif
3039 
3040 end function fm_new_value_string
3041 
3042 
3043 !> Resets the loop variable. For use in conjunction with fm_loop_over_list.
3044 subroutine fm_reset_loop
3045 ! Initialize the field manager if needed
3046 if (.not. module_is_initialized) then
3048 endif
3049 ! Reset the variables
3050 loop_list = ' '
3051 nullify(loop_list_p)
3052 
3053 end subroutine fm_reset_loop
3054 
3055 !> Return the root list to the value at initialization.
3056 !!
3057 !> For use in conjunction with fm_change_root.
3058 !!
3059 !! Users should use this routine before leaving their routine if they
3060 !! previously used fm_change_root.
3061 subroutine fm_return_root
3062 ! Initialize the field manager if needed
3063 if (.not. module_is_initialized) then
3065 endif
3066 ! restore the saved values to the current root
3067 root_p%name = save_root_name
3068 root_p%parent => save_root_parent_p
3069 ! set the pointer to the original root field
3070 root_p => root
3071 ! reset the save root name and parent variables
3072 save_root_name = ' '
3073 nullify(save_root_parent_p)
3074 
3075 end subroutine fm_return_root
3076 
3077 !> Return a pointer to the field if it exists relative to this_list_p,
3078 !! null otherwise
3079 !! @returns A pointer to the field name
3080 function get_field(name, this_list_p) &
3081  result(list_p)
3082 type (field_def), pointer :: list_p
3083 character(len=*), intent(in) :: name !< The name of a list that the user wishes to get information for
3084 type (field_def), pointer :: this_list_p !< A pointer to a list that serves as the base point
3085  !! for searching for name
3086 
3087 character(len=FMS_PATH_LEN) :: path
3088 character(len=fm_field_name_len) :: base
3089 type (field_def), pointer, save :: temp_p
3090 
3091 nullify(list_p)
3092 ! Get the path and base for name
3093 call find_base(name, path, base)
3094 ! Find the list if path is not empty
3095 if (path .ne. ' ') then
3096  temp_p => find_list(path, this_list_p, .false.)
3097  if (associated(temp_p)) then
3098  list_p => find_field(base, temp_p)
3099  else
3100  nullify(list_p)
3101  endif
3102 else
3103  list_p => find_field(base, this_list_p)
3104 endif
3105 
3106 end function get_field
3107 
3108 !> This function allows a user to rename a field without modifying the
3109 !! contents of the field.
3110 !!
3111 !> Function to modify the name of a field.
3112 !! Should be used with caution.
3113 !! @returns A flag to indicate whether the function operated with (FALSE) or
3114 !! without (TRUE) errors.
3115 function fm_modify_name(oldname, newname) &
3116  result(success)
3117 logical :: success
3118 character(len=*), intent(in) :: oldname !< The name of a field that the user wishes to change
3119  !! the name of
3120 character(len=*), intent(in) :: newname !< The name that the user wishes to change the name of
3121  !! the field to.
3122 
3123 character(len=FMS_PATH_LEN) :: path
3124 character(len=fm_field_name_len) :: base
3125 type (field_def), pointer, save :: list_p
3126 type (field_def), pointer, save :: temp_p
3127 ! Get the path and base for name
3128 call find_base(oldname, path, base)
3129 ! Find the list if path is not empty
3130 success = .false.
3131 if (path .ne. ' ') then
3132  temp_p => find_list(path, current_list_p, .false.)
3133  if (associated(temp_p)) then
3134  list_p => find_field(base, temp_p)
3135  if (associated(list_p)) then
3136  list_p%name = newname
3137  success = .true.
3138  endif
3139  else
3140  nullify(list_p)
3141  endif
3142 else
3143  list_p => find_field(base, current_list_p)
3144  if (associated(list_p)) then
3145  list_p%name = newname
3146  success = .true.
3147  endif
3148 endif
3149 
3150 end function fm_modify_name
3151 
3152 !> A function to initialize the values of the pointers. This will remove
3153 !! all fields and reset the field tree to only the root field.
3155  ! Initialize the root field
3156  integer :: io, ierr !< Error codes when reading the namelist
3157  integer :: logunit !< Unit number for the log file
3158 
3159  if (.not. module_is_initialized) then
3160 
3161  read (input_nml_file, nml=field_manager_nml, iostat=io)
3162  ierr = check_nml_error(io,"field_manager_nml")
3163 
3164  logunit = stdlog()
3165  if (mpp_pe() == mpp_root_pe()) write (logunit, nml=field_manager_nml)
3166 
3167  root_p => root
3168 
3169  field_type_name(integer_type) = 'integer'
3170  field_type_name(list_type) = 'list'
3171  field_type_name(logical_type) = 'logical'
3172  field_type_name(real_type) = 'real'
3173  field_type_name(string_type) = 'string'
3174 
3175  root%name = ' '
3176  root%index = 1
3177  root%parent => root_p
3178 
3179  root%field_type = list_type
3180 
3181  root%length = 0
3182  nullify(root%first_field)
3183  nullify(root%last_field)
3184  root%max_index = 0
3185  root%array_dim = 0
3186  if (allocated(root%i_value)) deallocate(root%i_value)
3187  if (allocated(root%l_value)) deallocate(root%l_value)
3188  if (allocated(root%r_value)) deallocate(root%r_value)
3189  if (allocated(root%s_value)) deallocate(root%s_value)
3190 
3191  nullify(root%next)
3192  nullify(root%prev)
3193 
3194  current_list_p => root
3195 
3196  nullify(loop_list_p)
3197  loop_list = ' '
3198 
3199  nullify(save_root_parent_p)
3200  save_root_name = ' '
3201 
3202  module_is_initialized = .true.
3203 
3204 endif
3205 
3206 end subroutine initialize_module_variables
3207 
3208 !> This function creates a new field and returns a pointer to that field.
3209 !!
3210 !> Allocate and initialize a new list in this_list_p list.
3211 !! @return a pointer to the list on success, or a null pointer
3212 !! on failure.
3213 function make_list(this_list_p, name) &
3214  result(list_p)
3215 type (field_def), pointer :: list_p
3216 type (field_def), pointer :: this_list_p !< Base of a list that the user wishes to add a list to
3217 character(len=*), intent(in) :: name !< name of a list that the user wishes to create
3218 
3219 type (field_def), pointer, save :: dummy_p
3220 integer :: out_unit
3221 
3222 out_unit = stdout()
3223 ! Check to see whether there is already a list with
3224 ! this name, and if so, return an error as list names
3225 ! must be unique
3226 dummy_p => find_field(name, this_list_p )
3227 if (associated(dummy_p)) then
3228 ! This list is already specified, return an error
3229  list_p => dummy_p
3230  return
3231 endif
3232 ! Create a field for the new list
3233 nullify(list_p)
3234 list_p => create_field(this_list_p, name)
3235 if (.not. associated(list_p)) then
3236  nullify(list_p)
3237  return
3238 endif
3239 ! Initialize the new list
3240 list_p%length = 0
3241 list_p%field_type = list_type
3242 if (allocated(list_p%i_value)) deallocate(list_p%i_value)
3243 if (allocated(list_p%l_value)) deallocate(list_p%l_value)
3244 if (allocated(list_p%r_value)) deallocate(list_p%r_value)
3245 if (allocated(list_p%s_value)) deallocate(list_p%s_value)
3246 
3247 end function make_list
3248 
3249 !> This is a function that provides the capability to return parameters
3250 !! associated with a field in a pair of strings.
3251 !!
3252 !> Given a name return a list of method names and control strings.
3253 !! This function should return strings similar to those in the field
3254 !! table if a comma delimited format is being used.
3255 !> @return A flag to indicate whether the function operated with (FALSE) or
3256 !! without (TRUE) errors
3257 function fm_query_method(name, method_name, method_control) &
3258  result(success)
3259 logical :: success
3260 character(len=*), intent(in) :: name !< name of a list that the user wishes to change to
3261 character(len=*), intent(out) :: method_name !< name of a parameter associated with the named field
3262 character(len=*), intent(out) :: method_control !< value of parameters associated with the named field
3263 
3264 character(len=FMS_PATH_LEN) :: path
3265 character(len=FMS_PATH_LEN) :: base
3266 character(len=FMS_PATH_LEN) :: name_loc
3267 logical :: recursive_t
3268 type (field_def), pointer, save :: temp_list_p
3269 type (field_def), pointer, save :: temp_value_p
3270 type (field_def), pointer, save :: this_field_p
3271 integer :: out_unit
3272 
3273  out_unit = stdout()
3274  success = .false.
3275  recursive_t = .true.
3276  method_name = " "
3277  method_control = " "
3278 ! Initialize the field manager if needed
3279 if (.not. module_is_initialized) call initialize_module_variables
3280 name_loc = lowercase(name)
3281 call find_base(name_loc, path, base)
3282 
3283  temp_list_p => find_list(name_loc, current_list_p, .false.)
3284 
3285 if (associated(temp_list_p)) then
3286 ! Find the entry values for the list.
3287  success = query_method(temp_list_p, recursive_t, base, method_name, method_control)
3288 else
3289 ! This is not a list but it may be a parameter with a value
3290 ! If so put the parameter value in method_name.
3291 
3292  temp_value_p => find_list(path, current_list_p, .false.)
3293  if (associated(temp_value_p)) then
3294 ! Find the entry values for this item.
3295  this_field_p => temp_value_p%first_field
3296 
3297  do while (associated(this_field_p))
3298  if ( this_field_p%name == base ) then
3299  method_name = this_field_p%s_value(1)
3300  method_control = ""
3301  success = .true.
3302  exit
3303  else
3304  success = .false.
3305  endif
3306  this_field_p => this_field_p%next
3307  enddo
3308 
3309  else
3310 ! Error following the path
3311  success = .false.
3312  endif
3313 endif
3314 
3315 end function fm_query_method
3316 
3317 !> A private function that can recursively recover values for parameters
3318 !! associated with a field.
3319 !> @return A flag to indicate whether the function operated with (FALSE) or
3320 !! without (TRUE) errors
3321 recursive function query_method(list_p, recursive, name, method_name, method_control) &
3322  result(success)
3323 logical :: success
3324 type (field_def), pointer :: list_p !< A pointer to the field that is of interest
3325 logical, intent(in) :: recursive !< A flag to enable recursive searching if true
3326 character(len=*), intent(in) :: name !< name of a list that the user wishes to change to
3327 character(len=*), intent(out) :: method_name !< name of a parameter associated with the named field
3328 character(len=*), intent(out) :: method_control !< value of parameters associated with the named field
3329 
3330 integer :: i
3331 character(len=64) :: scratch
3332 type (field_def), pointer :: this_field_p
3333 integer :: out_unit
3334 
3335 out_unit = stdout()
3336 
3337 ! Check for a valid list
3338 if (.not. associated(list_p) .or. list_p%field_type .ne. list_type) then
3339  success = .false.
3340 else
3341 
3342  ! set the default return value
3343  success = .true.
3344 
3345  this_field_p => list_p%first_field
3346 
3347  do while (associated(this_field_p))
3348  select case(this_field_p%field_type)
3349  case(list_type)
3350  ! If this is a list, then this is the method name
3351  if (recursive) then
3352  if (.not. query_method(this_field_p, .true., this_field_p%name, method_name, method_control)) then
3353  success = .false.
3354  exit
3355  else
3356  method_name = trim(method_name)//trim(this_field_p%name)
3357  endif
3358  endif
3359 
3360  case(integer_type)
3361  write (scratch,*) this_field_p%i_value
3362  call concat_strings(method_control, comma//trim(this_field_p%name)//' = '//trim(adjustl(scratch)))
3363 
3364  case(logical_type)
3365  write (scratch,'(l1)')this_field_p%l_value
3366  call concat_strings(method_control, comma//trim(this_field_p%name)//' = '//trim(adjustl(scratch)))
3367 
3368  case(real_type)
3369  write (scratch,*) this_field_p%r_value
3370  call concat_strings(method_control, comma//trim(this_field_p%name)//' = '//trim(adjustl(scratch)))
3371 
3372  case(string_type)
3373  call concat_strings(method_control, comma//trim(this_field_p%name)//' = '//trim(this_field_p%s_value(1)))
3374  do i = 2, this_field_p%max_index
3375  call concat_strings(method_control, comma//trim(this_field_p%s_value(i)))
3376  enddo
3377 
3378  case default
3379  success = .false.
3380  exit
3381 
3382  end select
3383  this_field_p => this_field_p%next
3384  enddo
3385 endif
3386 
3387 end function query_method
3388 
3389 !> private function: appends str2 to the end of str1, with length check
3390 subroutine concat_strings(str1,str2)
3391  character(*), intent(inout) :: str1
3392  character(*), intent(in) :: str2
3393 
3394  character(64) :: n1,n2 ! for error reporting
3395 
3396  if (len_trim(str1)+len_trim(str2)>len(str1)) then
3397  write(n1,*)len(str1)
3398  write(n2,*)len_trim(str1)+len_trim(str2)
3399  call mpp_error(fatal,'length of output string ('//trim(adjustl(n1))&
3400  //') is not enough for the result of concatenation (len='&
3401  //trim(adjustl(n2))//')')
3402  endif
3403  str1 = trim(str1)//trim(str2)
3404 end subroutine concat_strings
3405 
3406 !> A function that allows the user to copy a field and add a suffix to
3407 !! the name of the new field.
3408 !!
3409 !> Given the name of a pre-existing field and a suffix, this function
3410 !! will create a new field. The name of the new field will be that of
3411 !! the old field with a suffix supplied by the user.
3412 !! @return index of the field that has been created by the copy
3413 function fm_copy_list(list_name, suffix, create ) &
3414  result(index)
3415 integer :: index
3416 character(len=*), intent(in) :: list_name !< name of a field that the user wishes to copy
3417 character(len=*), intent(in) :: suffix !< suffix that will be added to list_name when
3418  !! field is copied
3419 logical, intent(in), optional :: create !< flag to create new list if applicable
3420 
3421 character(len=fm_string_len), dimension(:), allocatable :: control
3422 character(len=fm_string_len), dimension(:), allocatable :: method
3423 character(len=fm_string_len) :: head
3424 character(len=fm_string_len) :: list_name_new
3425 character(len=fm_string_len) :: tail
3426 character(len=fm_string_len) :: val_str
3427 integer :: n
3428 integer :: num_meth
3429 integer :: val_int
3430 logical :: found_methods
3431 logical :: got_value
3432 logical :: recursive_t
3433 logical :: success
3434 logical :: val_logical
3435 real(r8_kind) :: val_real
3436 type (field_def), pointer, save :: temp_field_p
3437 type (field_def), pointer, save :: temp_list_p
3438 integer :: out_unit
3439 
3440 out_unit = stdout()
3441 
3442 
3443 num_meth= 1
3444 list_name_new = trim(list_name)//trim(suffix)
3445  recursive_t = .true.
3446 ! Initialize the field manager if needed
3447 if (.not. module_is_initialized) then
3449 endif
3450 
3451 if (list_name .eq. ' ') then
3452 ! If list is empty, then dump the current list
3453  temp_list_p => current_list_p
3454  success = .true.
3455 else
3456 ! Get a pointer to the list
3457  temp_list_p => find_list(list_name, current_list_p, .false.)
3458  if (associated(temp_list_p)) then
3459  success = .true.
3460  else
3461 ! Error following the path
3462  success = .false.
3463  endif
3464 endif
3465 ! Find the list
3466 if (success) then
3467  found_methods = fm_find_methods(trim(list_name), method, control)
3468  do n = 1, size(method)
3469  if (len_trim(method(n)) > 0 ) then
3470  index = fm_new_list(trim(list_name_new)//list_sep//method(n), create = create)
3471  call find_base(method(n), head, tail)
3472  temp_field_p => find_list(trim(list_name)//list_sep//head,temp_list_p, .false.)
3473  temp_field_p => find_field(tail,temp_field_p)
3474  select case (temp_field_p%field_type)
3475  case (integer_type)
3476  got_value = fm_get_value( trim(list_name)//list_sep//method(n), val_int)
3477  if ( fm_new_value( trim(list_name_new)//list_sep//method(n), val_int, &
3478  create = create, append = .true.) < 0 ) &
3479  call mpp_error(fatal, trim(error_header)//'Could not set the '//trim(method(n))//&
3480  ' for '//trim(list_name)//trim(suffix))
3481 
3482  case (logical_type)
3483  got_value = fm_get_value( trim(list_name)//list_sep//method(n), val_logical)
3484  if ( fm_new_value( trim(list_name_new)//list_sep//method(n), val_logical, &
3485  create = create, append = .true.) < 0 ) &
3486  call mpp_error(fatal, trim(error_header)//'Could not set the '//trim(method(n))//&
3487  ' for '//trim(list_name)//trim(suffix))
3488 
3489  case (real_type)
3490  got_value = fm_get_value( trim(list_name)//list_sep//method(n), val_real)
3491  if ( fm_new_value( trim(list_name_new)//list_sep//method(n), val_real, &
3492  create = create, append = .true.) < 0 ) &
3493  call mpp_error(fatal, trim(error_header)//'Could not set the '//trim(method(n))//&
3494  ' for '//trim(list_name)//trim(suffix))
3495 
3496  case (string_type)
3497  got_value = fm_get_value( trim(list_name)//list_sep//method(n), val_str)
3498  if ( fm_new_value( trim(list_name_new)//list_sep//method(n), val_str, &
3499  create = create, append = .true.) < 0 ) &
3500  call mpp_error(fatal, trim(error_header)//'Could not set the '//trim(method(n))//&
3501  ' for '//trim(list_name)//trim(suffix))
3502  case default
3503  end select
3504 
3505  endif
3506  enddo
3507 endif
3508 
3509 end function fm_copy_list
3510 
3511 !> This function retrieves all the methods associated with a field.
3512 !!
3513 !> This is different from fm_query_method in that this function gets all
3514 !! the methods associated as opposed to 1 method.
3515 !! @return A flag to indicate whether the function operated with (FALSE) or
3516 !! without (TRUE) errors.
3517 function fm_find_methods(list_name, methods, control ) &
3518  result(success)
3519 logical :: success
3520 character(len=*), intent(in) :: list_name !< The name of a list that the user wishes to find methods for
3521 character(len=*), intent(out), dimension(:) :: methods !< An array of the methods associated with list_name
3522 character(len=*), intent(out), dimension(:) :: control !< An array of the parameters associated with methods
3523 
3524 integer :: num_meth
3525 logical :: recursive_t
3526 type (field_def), pointer, save :: temp_list_p
3527 integer :: out_unit
3528 
3529 out_unit = stdout()
3530 num_meth= 1
3531 ! Check whether to do things recursively
3532  recursive_t = .true.
3533 
3534 if (.not. module_is_initialized) then
3536 endif
3537 
3538 if (list_name .eq. ' ') then
3539 ! If list is empty, then dump the current list
3540  temp_list_p => current_list_p
3541  success = .true.
3542 else
3543 ! Get a pointer to the list
3544  temp_list_p => find_list(list_name, current_list_p, .false.)
3545  if (associated(temp_list_p)) then
3546  success = .true.
3547  else
3548 ! Error following the path
3549  success = .false.
3550  endif
3551 endif
3552 ! Find the list
3553 if (success) then
3554  success = find_method(temp_list_p, recursive_t, num_meth, methods, control)
3555 endif
3556 
3557 end function fm_find_methods
3558 
3559 !> Given a field list pointer this function retrieves methods and
3560 !! associated parameters for the field list.
3561 !! @returns A flag to indicate whether the function operated with (FALSE) or
3562 !! without (TRUE) errors.
3563 recursive function find_method(list_p, recursive, num_meth, method, control) &
3564  result(success)
3565 logical :: success
3566 type (field_def), pointer :: list_p !< A pointer to the field of interest
3567 logical, intent(in) :: recursive !< If true, search recursively for fields
3568 integer, intent(inout) :: num_meth !< The number of methods found
3569 character(len=*), intent(out), dimension(:) :: method !< The methods associated with the field pointed to by list_p
3570 character(len=*), intent(out), dimension(:) :: control !< The control parameters for the methods found
3571 
3572 character(len=FMS_PATH_LEN) :: scratch
3573 integer :: i
3574 integer :: n
3575 type (field_def), pointer, save :: this_field_p
3576 integer :: out_unit
3577 
3578 out_unit = stdout()
3579 ! Check for a valid list
3580 if (.not. associated(list_p) .or. list_p%field_type .ne. list_type) then
3581  success = .false.
3582 else
3583 ! set the default return value
3584  success = .true.
3585 
3586  this_field_p => list_p%first_field
3587 
3588  do while (associated(this_field_p))
3589  select case(this_field_p%field_type)
3590  case(list_type)
3591 ! If this is a list, then this is the method name
3592  if ( this_field_p%length > 1) then
3593  do n = num_meth+1, num_meth + this_field_p%length - 1
3594  write (method(n),'(a,a,a,$)') trim(method(num_meth)), &
3595  trim(this_field_p%name), list_sep
3596  enddo
3597  write (method(num_meth),'(a,a,a,$)') trim(method(num_meth)), &
3598  trim(this_field_p%name), list_sep
3599  else
3600  write (method(num_meth),'(a,a,a,$)') trim(method(num_meth)), &
3601  trim(this_field_p%name), list_sep
3602  endif
3603  success = find_method(this_field_p, .true., num_meth, method, control)
3604 
3605  case(integer_type)
3606  write (scratch,*) this_field_p%i_value
3607  call strip_front_blanks(scratch)
3608  write (method(num_meth),'(a,a)') trim(method(num_meth)), &
3609  trim(this_field_p%name)
3610  write (control(num_meth),'(a)') &
3611  trim(scratch)
3612  num_meth = num_meth + 1
3613 
3614 
3615  case(logical_type)
3616 
3617  write (method(num_meth),'(a,a)') trim(method(num_meth)), &
3618  trim(this_field_p%name)
3619  write (control(num_meth),'(l1)') &
3620  this_field_p%l_value
3621  num_meth = num_meth + 1
3622 
3623  case(real_type)
3624 
3625  if(allocated(this_field_p%r_value)) write (scratch,*) this_field_p%r_value
3626  call strip_front_blanks(scratch)
3627  write (method(num_meth),'(a,a)') trim(method(num_meth)), &
3628  trim(this_field_p%name)
3629  write (control(num_meth),'(a)') &
3630  trim(scratch)
3631  num_meth = num_meth + 1
3632 
3633 
3634  case(string_type)
3635  write (method(num_meth),'(a,a)') trim(method(num_meth)), &
3636  trim(this_field_p%name)
3637  write (control(num_meth),'(a)') &
3638  trim(this_field_p%s_value(1))
3639  do i = 2, this_field_p%max_index
3640  write (control(num_meth),'(a,a,$)') comma//trim(this_field_p%s_value(i))
3641  enddo
3642  num_meth = num_meth + 1
3643 
3644 
3645  case default
3646  success = .false.
3647  exit
3648 
3649  end select
3650 
3651  this_field_p => this_field_p%next
3652  enddo
3653 endif
3654 
3655 end function find_method
3656 
3657 #include "field_manager_r4.fh"
3658 #include "field_manager_r8.fh"
3659 
3660 end module field_manager_mod
3661 !> @}
3662 ! close documentation grouping
integer function parse_integer(text, label, parse_ival)
integer function, public fm_copy_list(list_name, suffix, create)
A function that allows the user to copy a field and add a suffix to the name of the new field.
type(field_def) function, pointer, private find_list(path, relative_p, create)
Find and return a pointer to the specified list, relative to relative_p. Return a null pointer on err...
recursive logical function query_method(list_p, recursive, name, method_name, method_control)
A private function that can recursively recover values for parameters associated with a field.
subroutine, private find_base(name, path, base)
A subroutine that splits a listname into a path and a base.
integer function fm_new_value_integer(name, new_ival, create, index, append)
Assigns a given value to a given field.
integer, parameter, public fm_string_len
The length of a character string representing character values for the field.
integer function fm_new_value_logical(name, new_lval, create, index, append)
Assigns a given value to a given field.
logical function set_list_stuff()
If the pointer matches to the right list, extract the field information. Used in fm_loop_over_list.
type(field_def) function, pointer, private create_field(parent_p, name)
A function to create a field as a child of parent_p. This will return a pointer to a field_def type.
subroutine strip_front_blanks(name)
A routine to strip whitespace from the start of character strings.
integer, parameter, public model_land
Land model.
function parse_strings(text, label, values)
subroutine concat_strings(str1, str2)
private function: appends str2 to the end of str1, with length check
integer function find_field_index_new(field_name)
integer function, public fm_get_length(name)
A function to return how many elements are contained within the named list or entry.
logical function fm_get_value_integer(name, get_ival, index)
character(len=8) function, public fm_get_type(name)
A function to return the type of the named field.
subroutine, public fm_reset_loop
Resets the loop variable. For use in conjunction with fm_loop_over_list.
logical function, public fm_exists(name)
A function to test whether a named field exists.
character(len=11), dimension(num_models), parameter, public model_names
Model names, e.g. MODEL_NAMES(MODEL_OCEAN) is 'oceanic'.
logical function, public fm_change_list(name)
Change the current list. Return true on success, false otherwise.
subroutine read_field_table_yaml(nfields, table_name)
Routine to read and parse the field table yaml.
integer function, public fm_new_list(name, create, keep)
A function to create a new list.
type(field_mgr_type), dimension(:), allocatable, private fields
fields of field_mgr_type
subroutine, public get_field_methods(n, methods)
A routine to obtain all the methods associated with a field.
character(len=fms_path_len) function, public fm_get_current_list()
A function to return the full path of the current list.
subroutine, private find_head(name, head, rest)
Find the first list for a name by splitting the name into a head and the rest.
integer function, public fm_get_index(name)
A function to return the index of a named field.
subroutine, public field_manager_end
Destructor for field manager.
integer function find_field_index_old(model, field_name)
Function to return the index of the field.
subroutine new_name_yaml(list_name, method_name_in, val_name_in)
Subroutine to add new values to list parameters.
type(field_def) function, pointer, private get_field(name, this_list_p)
Return a pointer to the field if it exists relative to this_list_p, null otherwise.
subroutine, public field_manager_init(nfields, table_name)
Routine to initialize the field manager.
logical function, public fm_query_method(name, method_name, method_control)
This is a function that provides the capability to return parameters associated with a field in a pai...
integer, parameter, public model_coupler
Ice model.
subroutine, private initialize_module_variables
A function to initialize the values of the pointers. This will remove all fields and reset the field ...
integer, parameter, public fm_field_name_len
The length of a character string representing the field name.
type(field_def) function, pointer, private make_list(this_list_p, name)
This function creates a new field and returns a pointer to that field.
recursive logical function find_method(list_p, recursive, num_meth, method, control)
Given a field list pointer this function retrieves methods and associated parameters for the field li...
subroutine, public get_field_method(n, m, method)
A routine to get a specified method.
subroutine, public get_field_info(n, fld_type, fld_name, model, num_methods)
This routine allows access to field information given an index.
logical function fm_get_value_logical(name, get_lval, index)
integer, parameter, public fm_type_name_len
The length of a character string representing the various types that the values of the field can take...
logical use_field_table_yaml
.True. if using the field_table.yaml, .false. if using the legacy field_table
subroutine read_field_table_legacy(nfields, table_name)
Routine to read and parse the field table yaml.
logical function, public fm_modify_name(oldname, newname)
This function allows a user to rename a field without modifying the contents of the field.
logical function, public fm_dump_list(name, recursive, unit)
A function to list properties associated with a field.
logical recursive function, private dump_list(list_p, recursive, depth, out_unit)
This is a function that lists the parameters of a field.
integer, parameter, public model_ocean
Ocean model.
subroutine, public fm_return_root
Return the root list to the value at initialization.
integer, parameter, public no_field
The value returned if a field is not defined.
subroutine, public fm_init_loop(loop_list, iter)
given a name of the list, prepares an iterator over the list content. If the name of the given list i...
function parse_integers(text, label, values)
logical function fm_loop_over_list_new(iter, name, field_type, index)
given a list iterator, returns information about curren list element and advances the iterator to the...
integer, parameter, public model_ice
Ice model.
integer function fm_new_value_string(name, new_sval, create, index, append)
Assigns a given value to a given field.
logical function, public fm_change_root(name)
Change the root list.
subroutine new_name(list_name, method_name_in, val_name_in)
Subroutine to add new values to list parameters.
integer function parse_string(text, label, parse_sval)
integer, parameter, public model_atmos
Atmospheric model.
integer, parameter, public num_models
Number of models (ATMOS, OCEAN, LAND, ICE, COUPLER).
type(field_def) function, pointer, private find_field(name, this_list_p)
Find and return a pointer to the field in the specified list. Return a null pointer on error.
logical function, public fm_find_methods(list_name, methods, control)
This function retrieves all the methods associated with a field.
logical function fm_loop_over_list_old(list, name, field_type, index)
Iterates through the given list.
logical function fm_get_value_string(name, get_sval, index)
Returns an index corresponding to the given field name.
An overloaded function to find and extract a value for a named field.
A function for looping over a list.
An overloaded function to assign a value to a field.
A function to parse an integer or an array of integers, a real or an array of reals,...
Private type for internal use.
Private type for internal use.
Private type for internal use.
Private type for internal use.
Iterator over the field manager list.
This method_type is a way to allow a component module to alter the parameters it needs for various tr...
This method_type is the same as method_type except that the method_control string is not present....
This is the same as method_type except that the method_control and method_name strings are not presen...
subroutine, public build_fmtable(fmTable, filename)
Subroutine to populate an fmTable by reading a yaml file, given an optional filename.
Definition: fm_yaml.F90:97
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
integer function stdout()
This function returns the current standard fortran unit numbers for output.
Definition: mpp_util.inc:42
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_pe()
Returns processor ID.
Definition: mpp_util.inc:406
Error handler.
Definition: mpp.F90:381