field_manager/fm_util.F90

   1 !***********************************************************************
   2 !*                   GNU Lesser General Public License
   3 !*
   4 !* This file is part of the GFDL Flexible Modeling System (FMS).
   5 !*
   6 !* FMS is free software: you can redistribute it and/or modify it under
   7 !* the terms of the GNU Lesser General Public License as published by
   8 !* the Free Software Foundation, either version 3 of the License, or (at
   9 !* your option) any later version.
  10 !*
  11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
  12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 !* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 !* for more details.
  15 !*
  16 !* You should have received a copy of the GNU Lesser General Public
  17 !* License along with FMS.  If not, see <http://www.gnu.org/licenses/>.
  18 !***********************************************************************
  19 !> @defgroup fm_util_mod fm_util_mod
  20 !> @ingroup field_manager
  21 !> @brief This module provides utility routines for the field manager.
  22 !!
  23 !> Routines for error catching, reporting and
  24 !! termination while interfacing with the field manager.
  25 !> @author Richard D. Slater
  26
  27 !> @addtogroup fm_util_mod
  28 !> @{
  29 module fm_util_mod  !{
  30
  31 use field_manager_mod, only: fm_string_len, fm_field_name_len, fm_type_name_len
  32 use field_manager_mod, only: fm_get_type, fm_get_index, fm_get_length
  33 use field_manager_mod, only: fm_get_current_list, fm_new_list, fm_change_list, fm_loop_over_list
  34 use field_manager_mod, only: fm_new_value, fm_get_value
  35 use field_manager_mod, only: fm_exists, fm_dump_list
  36 use fms_mod,           only: FATAL, stdout
  37 use mpp_mod,           only: mpp_error
  38 use platform_mod,      only: r4_kind, r8_kind, FMS_PATH_LEN
  39
  40 implicit none
  41
  42 private
  43
  44 public  fm_util_start_namelist
  45 public  fm_util_end_namelist
  46 public  fm_util_check_for_bad_fields
  47 public  fm_util_set_caller
  48 public  fm_util_reset_caller
  49 public  fm_util_set_no_overwrite
  50 public  fm_util_reset_no_overwrite
  51 public  fm_util_set_good_name_list
  52 public  fm_util_reset_good_name_list
  53 public  fm_util_get_length
  54 public  fm_util_get_integer
  55 public  fm_util_get_logical
  56 public  fm_util_get_real
  57 public  fm_util_get_string
  58 public  fm_util_get_integer_array
  59 public  fm_util_get_logical_array
  60 public  fm_util_get_real_array
  61 public  fm_util_get_string_array
  62 public  fm_util_set_value
  63 public  fm_util_set_value_integer_array
  64 public  fm_util_set_value_real_array
  65 public  fm_util_set_value_logical_array
  66 public  fm_util_set_value_string_array
  67 public  fm_util_set_value_integer
  68 public  fm_util_set_value_logical
  69 public  fm_util_set_value_real
  70 public  fm_util_set_value_string
  71 !public  fm_util_get_index
  72 public  fm_util_get_index_list
  73 public  fm_util_get_index_string
  74
  75 !
  76 !       Public variables
  77 !
  78
  79 character(len=128), public      :: fm_util_default_caller = ' '
  80
  81 !
  82 !       private parameters
  83 !
  84
  85 character(len=48), parameter    :: mod_name = 'fm_util_mod'
  86
  87 !
  88 !       Private variables
  89 !
  90
  91 character(len=128)              :: save_default_caller = ' '
  92 character(len=128)              :: default_good_name_list = ' '
  93 character(len=128)              :: save_default_good_name_list = ' '
  94 logical                         :: default_no_overwrite = .false.
  95 logical                         :: save_default_no_overwrite = .false.
  96 character(len=FMS_PATH_LEN)     :: save_current_list
  97 character(len=FMS_PATH_LEN)     :: save_path
  98 character(len=FMS_PATH_LEN)     :: save_name
  99 ! Include variable "version" to be written to log file.
 100 #include<file_version.h>
 101
 102 !
 103 !        Interface definitions for overloaded routines
 104 !
 105
 106 !interface  fm_util_get_value  !{
 107   !module procedure  fm_util_get_value_integer
 108   !module procedure  fm_util_get_value_logical
 109   !module procedure  fm_util_get_value_real
 110   !module procedure  fm_util_get_value_string
 111   !module procedure  fm_util_get_value_integer_array
 112   !module procedure  fm_util_get_value_logical_array
 113   !module procedure  fm_util_get_value_real_array
 114   !module procedure  fm_util_get_value_string_array
 115 !end interface  !}
 116
 117 !> @}
 118
 119 interface fm_util_set_value_real
 120   module procedure  fm_util_set_value_real_r4
 121   module procedure  fm_util_set_value_real_r8
 122 end interface fm_util_set_value_real
 123
 124 interface fm_util_set_value_real_array
 125   module procedure  fm_util_set_value_real_array_r4
 126   module procedure  fm_util_set_value_real_array_r8
 127 end interface fm_util_set_value_real_array
 128
 129 !> @ingroup fm_util_mod
 130 interface  fm_util_set_value  !{
 131   module procedure  fm_util_set_value_integer_array
 132   module procedure  fm_util_set_value_real_array_r4
 133   module procedure  fm_util_set_value_real_array_r8
 134   module procedure  fm_util_set_value_logical_array
 135   module procedure  fm_util_set_value_string_array
 136   module procedure  fm_util_set_value_real_r4
 137   module procedure  fm_util_set_value_real_r8
 138   module procedure  fm_util_set_value_integer
 139   module procedure  fm_util_set_value_logical
 140   module procedure  fm_util_set_value_string
 141 end interface  !}
 142
 143 !interface  fm_util_get_index  !{
 144   !module procedure  fm_util_get_index_list
 145   !module procedure  fm_util_get_index_string
 146 !end interface  !}
 147
 148 !> @addtogroup fm_util_mod
 149 !> @{
 150
 151 contains
 152
 153 !> Set the default value for the optional "caller" variable used in many of these
 154 !! subroutines. If the argument is blank, then set the default to blank, otherwise
 155 !! the deault will have brackets placed around the argument.
 156 subroutine fm_util_set_caller(caller)  !{
 157
 158 implicit none
 159
 160 !
 161 !       arguments
 162 !
 163
 164 character(len=*), intent(in)          :: caller
 165
 166 !
 167 !       Local variables
 168 !
 169
 170 !
 171 !       save the default caller string
 172 !
 173
 174 save_default_caller = fm_util_default_caller
 175
 176 !
 177 !       set the default caller string
 178 !
 179
 180 if (caller .eq. ' ') then  !{
 181   fm_util_default_caller = ' '
 182 else  !}{
 183   fm_util_default_caller = '[' // trim(caller) // ']'
 184 endif  !}
 185
 186 return
 187
 188 end subroutine fm_util_set_caller  !}
 189
 190 !#######################################################################
 191
 192 !> Reset the default value for the optional "caller" variable used in many of these
 193 !! subroutines to blank.
 194 subroutine fm_util_reset_caller  !{
 195
 196 implicit none
 197
 198 !
 199 !       arguments
 200 !
 201
 202 !
 203 !       Local variables
 204 !
 205
 206 !
 207 !       reset the default caller string
 208 !
 209
 210 fm_util_default_caller = save_default_caller
 211 save_default_caller = ' '
 212
 213 return
 214
 215 end subroutine fm_util_reset_caller  !}
 216
 217 !#######################################################################
 218
 219 !> Set the default value for the optional "good_name_list" variable used in many of these
 220 !! subroutines.
 221 subroutine fm_util_set_good_name_list(good_name_list)  !{
 222
 223 implicit none
 224
 225 !
 226 !       arguments
 227 !
 228
 229 character(len=*), intent(in)          :: good_name_list
 230
 231 !
 232 !       Local variables
 233 !
 234
 235 !
 236 !       save the default good_name_list string
 237 !
 238
 239 save_default_good_name_list = default_good_name_list
 240
 241 !
 242 !       set the default good_name_list string
 243 !
 244
 245 default_good_name_list = good_name_list
 246
 247 return
 248
 249 end subroutine fm_util_set_good_name_list  !}
 250
 251 !#######################################################################
 252
 253 !> Reset the default value for the optional "good_name_list" variable used in many of these
 254 !! subroutines to the saved value.
 255 subroutine fm_util_reset_good_name_list  !{
 256
 257 implicit none
 258
 259 !
 260 !       arguments
 261 !
 262
 263 !
 264 !       Local variables
 265 !
 266
 267 !
 268 !       reset the default good_name_list string
 269 !
 270
 271 default_good_name_list = save_default_good_name_list
 272 save_default_good_name_list = ' '
 273
 274 return
 275
 276 end subroutine fm_util_reset_good_name_list  !}
 277
 278 !#######################################################################
 279
 280 !> Set the default value for the optional "no_overwrite" variable used in some of these
 281 !! subroutines.
 282 subroutine fm_util_set_no_overwrite(no_overwrite)  !{
 283
 284 implicit none
 285
 286 !
 287 !       arguments
 288 !
 289
 290 logical, intent(in)          :: no_overwrite
 291
 292 !
 293 !       Local variables
 294 !
 295
 296 !
 297 !       save the default no_overwrite string
 298 !
 299
 300 save_default_no_overwrite = default_no_overwrite
 301
 302 !
 303 !       set the default no_overwrite value
 304 !
 305
 306 default_no_overwrite = no_overwrite
 307
 308 return
 309
 310 end subroutine fm_util_set_no_overwrite  !}
 311
 312 !#######################################################################
 313
 314 !> Reset the default value for the optional "no_overwrite" variable used in some of these
 315 !! subroutines to false.
 316 subroutine fm_util_reset_no_overwrite  !{
 317
 318 implicit none
 319
 320 !
 321 !       arguments
 322 !
 323
 324 !
 325 !       Local variables
 326 !
 327
 328 !
 329 !       reset the default no_overwrite value
 330 !
 331
 332 default_no_overwrite = save_default_no_overwrite
 333 save_default_no_overwrite = .false.
 334
 335 return
 336
 337 end subroutine fm_util_reset_no_overwrite  !}
 338
 339 !#######################################################################
 340
 341 !> Check for unrecognized fields in a list
 342 subroutine fm_util_check_for_bad_fields(list, good_fields, caller)  !{
 343
 344 implicit none
 345
 346 !
 347 !       arguments
 348 !
 349
 350 character(len=*), intent(in)                    :: list
 351 character(len=*), intent(in), dimension(:)      :: good_fields
 352 character(len=*), intent(in), optional          :: caller
 353
 354 !
 355 !       Local parameters
 356 !
 357
 358 character(len=48), parameter  :: sub_name = 'fm_util_check_for_bad_fields'
 359
 360 !
 361 !       Local variables
 362 !
 363
 364 logical                                 :: fm_success
 365 integer                                 :: i
 366 integer                                 :: ind
 367 integer                                 :: list_length
 368 integer                                 :: good_length
 369 character(len=fm_type_name_len)         :: typ
 370 character(len=fm_field_name_len)        :: name
 371 logical                                 :: found
 372 character(len=256)                      :: error_header
 373 character(len=256)                      :: warn_header
 374 character(len=256)                      :: note_header
 375 character(len=128)                      :: caller_str
 376 integer                         :: out_unit
 377
 378 out_unit = stdout()
 379
 380 !
 381 !       set the caller string and headers
 382 !
 383
 384 if (present(caller)) then  !{
 385   caller_str = '[' // trim(caller) // ']'
 386 else  !}{
 387   caller_str = fm_util_default_caller
 388 endif  !}
 389
 390 error_header = '==>Error from ' // trim(mod_name) //   &
 391                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 392 warn_header = '==>Warning from ' // trim(mod_name) //  &
 393               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 394 note_header = '==>Note from ' // trim(mod_name) //     &
 395               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 396
 397 !
 398 !       check that a list is given (fatal if not)
 399 !
 400
 401 if (list .eq. ' ') then  !{
 402   write (out_unit,*) trim(error_header) // ' Empty list given'
 403   call mpp_error(FATAL, trim(error_header) // ' Empty list given')
 404 endif  !}
 405
 406 !
 407 !       Check that we have been given a list
 408 !
 409
 410 if (fm_get_type(list) .ne. 'list') then  !{
 411   write (out_unit,*) trim(error_header) // ' Not given a list: ' // trim(list)
 412   call mpp_error(FATAL, trim(error_header) // ' Not given a list: ' // trim(list))
 413 endif  !}
 414
 415 !
 416 !       Get the list length
 417 !
 418
 419 list_length = fm_get_length(list)
 420 if (list_length .lt. 0) then  !{
 421   call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(list))
 422 endif  !}
 423
 424 !
 425 !       Get the number of good fields
 426 !
 427
 428 good_length = size(good_fields)
 429
 430 if (list_length .lt. good_length) then  !{
 431
 432 !
 433 !       If the list length is less than the number of good fields this is an error
 434 !       as the list should be fully populated and we'll check which extra fields
 435 !       are given in good_fields
 436 !
 437
 438   write (out_unit,*) trim(error_header), ' List length < number of good fields (',       &
 439        list_length, ' < ', good_length, ') in list ', trim(list)
 440
 441   write (out_unit,*)
 442   write (out_unit,*) 'The list contains the following fields:'
 443   fm_success= fm_dump_list(list, .false.)
 444   write (out_unit,*)
 445   write (out_unit,*) 'The supposed list of good fields is:'
 446   do i = 1, good_length  !{
 447     if (fm_exists(trim(list) // '/' // good_fields(i))) then  !{
 448       write (out_unit,*) 'List field: "', trim(good_fields(i)), '"'
 449     else  !}{
 450       write (out_unit,*) 'EXTRA good field: "', trim(good_fields(i)), '"'
 451     endif  !}
 452   enddo  !} i
 453   write (out_unit,*)
 454
 455   call mpp_error(FATAL, trim(error_header) //                                           &
 456        ' List length < number of good fields for list: ' // trim(list))
 457
 458 elseif (list_length .gt. good_length) then  !}{
 459
 460 !
 461 !       If the list length is greater than the number of good fields this is an error
 462 !       as the there should not be any more fields than those given in the good fields list
 463 !       and we'll check which extra fields are given in the list
 464 !
 465
 466   write (out_unit,*) trim(warn_header), 'List length > number of good fields (',        &
 467        list_length, ' > ', good_length, ') in list ', trim(list)
 468
 469   write (out_unit,*) trim(error_header), ' Start of list of fields'
 470   do while (fm_loop_over_list(list, name, typ, ind))  !{
 471     found = .false.
 472     do i = 1, good_length  !{
 473       found = found .or. (name .eq. good_fields(i))
 474     enddo  !} i
 475     if (found) then  !{
 476       write (out_unit,*) 'Good list field: "', trim(name), '"'
 477     else  !}{
 478       write (out_unit,*) 'EXTRA list field: "', trim(name), '"'
 479     endif  !}
 480   enddo  !}
 481   write (out_unit,*) trim(error_header), ' End of list of fields'
 482
 483   call mpp_error(FATAL, trim(error_header) //                                           &
 484        ' List length > number of good fields for list: ' // trim(list))
 485
 486 endif  !}
 487
 488 !
 489 !       If the list length equals the number of good fields then all is good
 490 !
 491
 492 return
 493
 494 end subroutine fm_util_check_for_bad_fields  !}
 495
 496 !#######################################################################
 497
 498 !> Get the length of an element of the Field Manager tree
 499 function fm_util_get_length(name, caller)       &
 500          result (field_length)  !{
 501
 502 implicit none
 503
 504 !
 505 !       Return type
 506 !
 507
 508 integer :: field_length
 509
 510 !
 511 !       arguments
 512 !
 513
 514 character(len=*), intent(in)            :: name
 515 character(len=*), intent(in), optional  :: caller
 516
 517 !
 518 !       Local parameters
 519 !
 520
 521 character(len=48), parameter  :: sub_name = 'fm_util_get_length'
 522
 523 !
 524 !       Local variables
 525 !
 526
 527 character(len=256)              :: error_header
 528 character(len=256)              :: warn_header
 529 character(len=256)              :: note_header
 530 character(len=128)              :: caller_str
 531
 532 !
 533 !       set the caller string and headers
 534 !
 535
 536 if (present(caller)) then  !{
 537   caller_str = '[' // trim(caller) // ']'
 538 else  !}{
 539   caller_str = fm_util_default_caller
 540 endif  !}
 541
 542 error_header = '==>Error from ' // trim(mod_name) //   &
 543                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 544 warn_header = '==>Warning from ' // trim(mod_name) //  &
 545               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 546 note_header = '==>Note from ' // trim(mod_name) //     &
 547               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 548
 549 !
 550 !       check that a name is given (fatal if not)
 551 !
 552
 553 if (name .eq. ' ') then  !{
 554   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
 555 endif  !}
 556
 557 !
 558 !       Get the field's length
 559 !
 560
 561 field_length = fm_get_length(name)
 562 if (field_length .lt. 0) then  !{
 563   call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
 564 endif  !}
 565
 566 return
 567
 568 end function fm_util_get_length  !}
 569
 570 !#######################################################################
 571
 572 !> Get the index of an element of a string in the Field Manager tree
 573 function fm_util_get_index_string(name, string, caller)       &
 574          result (fm_index)  !{
 575
 576 implicit none
 577
 578 !
 579 !       Return type
 580 !
 581
 582 integer :: fm_index
 583
 584 !
 585 !       arguments
 586 !
 587
 588 character(len=*), intent(in)            :: name
 589 character(len=*), intent(in)            :: string
 590 character(len=*), intent(in), optional  :: caller
 591
 592 !
 593 !       Local parameters
 594 !
 595
 596 character(len=48), parameter  :: sub_name = 'fm_util_get_index_string'
 597
 598 !
 599 !       Local variables
 600 !
 601
 602 character(len=256)              :: error_header
 603 character(len=256)              :: warn_header
 604 character(len=256)              :: note_header
 605 character(len=128)              :: caller_str
 606 character(len=32)               :: index_str
 607 character(len=fm_type_name_len) :: fm_type
 608 character(len=fm_string_len)    :: fm_string
 609 integer                         :: i
 610 integer                         :: length
 611
 612 !
 613 !       set the caller string and headers
 614 !
 615
 616 if (present(caller)) then  !{
 617   caller_str = '[' // trim(caller) // ']'
 618 else  !}{
 619   caller_str = fm_util_default_caller
 620 endif  !}
 621
 622 error_header = '==>Error from ' // trim(mod_name) //   &
 623                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 624 warn_header = '==>Warning from ' // trim(mod_name) //  &
 625               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 626 note_header = '==>Note from ' // trim(mod_name) //     &
 627               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 628
 629 !
 630 !       check that a name is given (fatal if not)
 631 !
 632
 633 if (name .eq. ' ') then  !{
 634   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
 635 endif  !}
 636
 637 !
 638 !       Check the field's type and get the index
 639 !
 640
 641 fm_index = 0
 642 fm_type = fm_get_type(name)
 643 if (fm_type .eq. 'string') then  !{
 644   length = fm_get_length(name)
 645   if (length .lt. 0) then  !{
 646     call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
 647   endif  !}
 648   if (length .gt. 0) then  !{
 649     do i = 1, length  !{
 650       if (.not. fm_get_value(name, fm_string, index = i)) then  !{
 651         write (index_str,*) '(', i, ')'
 652         call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name) // trim(index_str))
 653       endif  !}
 654       if (fm_string .eq. string) then  !{
 655         fm_index = i
 656         exit
 657       endif  !}
 658     enddo  !} i
 659   endif  !}
 660 elseif (fm_type .eq. ' ') then  !}{
 661   call mpp_error(FATAL, trim(error_header) // ' Array does not exist: ' // trim(name))
 662 else  !}{
 663  call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
 664 endif  !}
 665
 666 !if (fm_index .eq. 0) then  !{
 667   !call mpp_error(FATAL, trim(error_header) // ' "' // trim(string) // '" does not exist in ' // trim(name))
 668 !endif  !}
 669
 670 return
 671
 672 end function fm_util_get_index_string  !}
 673
 674 !#######################################################################
 675
 676 !> Get the length of an element of the Field Manager tree
 677 function fm_util_get_index_list(name, caller)       &
 678          result (fm_index)  !{
 679
 680 implicit none
 681
 682 !
 683 !       Return type
 684 !
 685
 686 integer :: fm_index
 687
 688 !
 689 !       arguments
 690 !
 691
 692 character(len=*), intent(in)            :: name
 693 character(len=*), intent(in), optional  :: caller
 694
 695 !
 696 !       Local parameters
 697 !
 698
 699 character(len=48), parameter  :: sub_name = 'fm_util_get_index_list'
 700
 701 !
 702 !       Local variables
 703 !
 704
 705 character(len=256)              :: error_header
 706 character(len=256)              :: warn_header
 707 character(len=256)              :: note_header
 708 character(len=128)              :: caller_str
 709 character(len=fm_type_name_len) :: fm_type
 710
 711 !
 712 !       set the caller string and headers
 713 !
 714
 715 if (present(caller)) then  !{
 716   caller_str = '[' // trim(caller) // ']'
 717 else  !}{
 718   caller_str = fm_util_default_caller
 719 endif  !}
 720
 721 error_header = '==>Error from ' // trim(mod_name) //   &
 722                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 723 warn_header = '==>Warning from ' // trim(mod_name) //  &
 724               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 725 note_header = '==>Note from ' // trim(mod_name) //     &
 726               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 727
 728 !
 729 !       check that a name is given (fatal if not)
 730 !
 731
 732 if (name .eq. ' ') then  !{
 733   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
 734 endif  !}
 735
 736 !
 737 !       Check the field's type and get the index
 738 !
 739
 740 fm_index = 0
 741 fm_type = fm_get_type(name)
 742 if (fm_type .eq. 'list') then  !{
 743   fm_index = fm_get_index(name)
 744   if (fm_index .le. 0) then  !{
 745     call mpp_error(FATAL, trim(error_header) // ' List does not exist: ' // trim(name))
 746   endif  !}
 747 elseif (fm_type .eq. ' ') then  !}{
 748   call mpp_error(FATAL, trim(error_header) // ' List does not exist: ' // trim(name))
 749 else  !}{
 750  call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
 751 endif  !}
 752
 753
 754 return
 755
 756 end function fm_util_get_index_list  !}
 757
 758
 759 !#######################################################################
 760
 761 !> Get an integer value from the Field Manager tree.
 762 function fm_util_get_integer_array(name, caller)            &
 763          result (array)  !{
 764
 765 implicit none
 766
 767 !
 768 !       Return type
 769 !
 770
 771 integer, pointer, dimension(:) :: array
 772
 773 !
 774 !       arguments
 775 !
 776
 777 character(len=*), intent(in)            :: name
 778 character(len=*), intent(in), optional  :: caller
 779
 780 !
 781 !       Local parameters
 782 !
 783
 784 character(len=48), parameter  :: sub_name = 'fm_util_get_integer_array'
 785
 786 !
 787 !       Local variables
 788 !
 789
 790 character(len=256)              :: error_header
 791 character(len=256)              :: warn_header
 792 character(len=256)              :: note_header
 793 character(len=128)              :: caller_str
 794 character(len=32)               :: index_str
 795 character(len=fm_type_name_len) :: fm_type
 796 integer                         :: i
 797 integer                         :: length
 798
 799 nullify(array)
 800
 801 !
 802 !       set the caller string and headers
 803 !
 804
 805 if (present(caller)) then  !{
 806   caller_str = '[' // trim(caller) // ']'
 807 else  !}{
 808   caller_str = fm_util_default_caller
 809 endif  !}
 810
 811 error_header = '==>Error from ' // trim(mod_name) //   &
 812                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 813 warn_header = '==>Warning from ' // trim(mod_name) //  &
 814               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 815 note_header = '==>Note from ' // trim(mod_name) //     &
 816               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 817
 818 !
 819 !       check that a name is given (fatal if not)
 820 !
 821
 822 if (name .eq. ' ') then  !{
 823   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
 824 endif  !}
 825
 826 fm_type = fm_get_type(name)
 827 if (fm_type .eq. 'integer') then  !{
 828   length = fm_get_length(name)
 829   if (length .lt. 0) then  !{
 830     call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
 831   endif  !}
 832   if (length .gt. 0) then  !{
 833     allocate(array(length))
 834     do i = 1, length  !{
 835       if (.not. fm_get_value(name, array(i), index = i)) then  !{
 836         write (index_str,*) '(', i, ')'
 837         call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name) // trim(index_str))
 838       endif  !}
 839     enddo  !} i
 840   endif  !}
 841 elseif (fm_type .eq. ' ') then  !}{
 842   call mpp_error(FATAL, trim(error_header) // ' Array does not exist: ' // trim(name))
 843 else  !}{
 844  call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
 845 endif  !}
 846
 847 return
 848
 849 end function fm_util_get_integer_array  !}
 850
 851 !#######################################################################
 852
 853 !> Get a logical value from the Field Manager tree.
 854 function fm_util_get_logical_array(name, caller)            &
 855          result (array)  !{
 856
 857 implicit none
 858
 859 !
 860 !       Return type
 861 !
 862
 863 logical, pointer, dimension(:) :: array
 864
 865 !
 866 !       arguments
 867 !
 868
 869 character(len=*), intent(in)            :: name
 870 character(len=*), intent(in), optional  :: caller
 871
 872 !
 873 !       Local parameters
 874 !
 875
 876 character(len=48), parameter  :: sub_name = 'fm_util_get_logical_array'
 877
 878 !
 879 !       Local variables
 880 !
 881
 882 character(len=256)              :: error_header
 883 character(len=256)              :: warn_header
 884 character(len=256)              :: note_header
 885 character(len=128)              :: caller_str
 886 character(len=32)               :: index_str
 887 character(len=fm_type_name_len) :: fm_type
 888 integer                         :: i
 889 integer                         :: length
 890
 891 nullify(array)
 892
 893 !
 894 !       set the caller string and headers
 895 !
 896
 897 if (present(caller)) then  !{
 898   caller_str = '[' // trim(caller) // ']'
 899 else  !}{
 900   caller_str = fm_util_default_caller
 901 endif  !}
 902
 903 error_header = '==>Error from ' // trim(mod_name) //   &
 904                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 905 warn_header = '==>Warning from ' // trim(mod_name) //  &
 906               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 907 note_header = '==>Note from ' // trim(mod_name) //     &
 908               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 909
 910 !
 911 !       check that a name is given (fatal if not)
 912 !
 913
 914 if (name .eq. ' ') then  !{
 915   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
 916 endif  !}
 917
 918 fm_type = fm_get_type(name)
 919 if (fm_type .eq. 'logical') then  !{
 920   length = fm_get_length(name)
 921   if (length .lt. 0) then  !{
 922     call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
 923   endif  !}
 924   if (length .gt. 0) then  !{
 925     allocate(array(length))
 926     do i = 1, length  !{
 927       if (.not. fm_get_value(name, array(i), index = i)) then  !{
 928         write (index_str,*) '(', i, ')'
 929         call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name) // trim(index_str))
 930       endif  !}
 931     enddo  !} i
 932   endif  !}
 933 elseif (fm_type .eq. ' ') then  !}{
 934   call mpp_error(FATAL, trim(error_header) // ' Array does not exist: ' // trim(name))
 935 else  !}{
 936  call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
 937 endif  !}
 938
 939 return
 940
 941 end function fm_util_get_logical_array  !}
 942
 943 !#######################################################################
 944
 945 !> Get a real value from the Field Manager tree.
 946 function fm_util_get_real_array(name, caller)            &
 947          result (array)  !{
 948
 949 implicit none
 950
 951 !
 952 !       Return type
 953 !
 954
 955 real(r8_kind), pointer, dimension(:) :: array
 956
 957 !
 958 !       arguments
 959 !
 960
 961 character(len=*), intent(in)            :: name
 962 character(len=*), intent(in), optional  :: caller
 963
 964 !
 965 !       Local parameters
 966 !
 967
 968 character(len=48), parameter  :: sub_name = 'fm_util_get_real_array'
 969
 970 !
 971 !       Local variables
 972 !
 973
 974 character(len=256)              :: error_header
 975 character(len=256)              :: warn_header
 976 character(len=256)              :: note_header
 977 character(len=128)              :: caller_str
 978 character(len=32)               :: index_str
 979 character(len=fm_type_name_len) :: fm_type
 980 integer                         :: i
 981 integer                         :: length
 982
 983 nullify(array)
 984
 985 !
 986 !       set the caller string and headers
 987 !
 988
 989 if (present(caller)) then  !{
 990   caller_str = '[' // trim(caller) // ']'
 991 else  !}{
 992   caller_str = fm_util_default_caller
 993 endif  !}
 994
 995 error_header = '==>Error from ' // trim(mod_name) //   &
 996                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 997 warn_header = '==>Warning from ' // trim(mod_name) //  &
 998               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
 999 note_header = '==>Note from ' // trim(mod_name) //     &
1000               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1001
1002 !
1003 !       check that a name is given (fatal if not)
1004 !
1005
1006 if (name .eq. ' ') then  !{
1007   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
1008 endif  !}
1009
1010 fm_type = fm_get_type(name)
1011 if (fm_type .eq. 'real') then  !{
1012   length = fm_get_length(name)
1013   if (length .lt. 0) then  !{
1014     call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
1015   endif  !}
1016   if (length .gt. 0) then  !{
1017     allocate(array(length))
1018     do i = 1, length  !{
1019       if (.not. fm_get_value(name, array(i), index = i)) then  !{
1020         write (index_str,*) '(', i, ')'
1021         call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name) // trim(index_str))
1022       endif  !}
1023     enddo  !} i
1024   endif  !}
1025 elseif (fm_type .eq. ' ') then  !}{
1026   call mpp_error(FATAL, trim(error_header) // ' Array does not exist: ' // trim(name))
1027 else  !}{
1028  call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
1029 endif  !}
1030
1031 return
1032
1033 end function fm_util_get_real_array  !}
1034
1035 !#######################################################################
1036
1037
1038 !> Get a string value from the Field Manager tree.
1039 function fm_util_get_string_array(name, caller)            &
1040          result (array)  !{
1041
1042 implicit none
1043
1044 !
1045 !       Return type
1046 !
1047
1048 character(len=fm_string_len), pointer, dimension(:) :: array
1049
1050 !
1051 !       arguments
1052 !
1053
1054 character(len=*), intent(in)            :: name
1055 character(len=*), intent(in), optional  :: caller
1056
1057 !
1058 !       Local parameters
1059 !
1060
1061 character(len=48), parameter  :: sub_name = 'fm_util_get_string_array'
1062
1063 !
1064 !       Local variables
1065 !
1066
1067 character(len=256)              :: error_header
1068 character(len=256)              :: warn_header
1069 character(len=256)              :: note_header
1070 character(len=128)              :: caller_str
1071 character(len=32)               :: index_str
1072 character(len=fm_type_name_len) :: fm_type
1073 integer                         :: i
1074 integer                         :: length
1075
1076 nullify(array)
1077
1078 !
1079 !       set the caller string and headers
1080 !
1081
1082 if (present(caller)) then  !{
1083   caller_str = '[' // trim(caller) // ']'
1084 else  !}{
1085   caller_str = fm_util_default_caller
1086 endif  !}
1087
1088 error_header = '==>Error from ' // trim(mod_name) //   &
1089                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1090 warn_header = '==>Warning from ' // trim(mod_name) //  &
1091               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1092 note_header = '==>Note from ' // trim(mod_name) //     &
1093               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1094
1095 !
1096 !       check that a name is given (fatal if not)
1097 !
1098
1099 if (name .eq. ' ') then  !{
1100   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
1101 endif  !}
1102
1103 fm_type = fm_get_type(name)
1104 if (fm_type .eq. 'string') then  !{
1105   length = fm_get_length(name)
1106   if (length .lt. 0) then  !{
1107     call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
1108   endif  !}
1109   if (length .gt. 0) then  !{
1110     allocate(array(length))
1111     do i = 1, length  !{
1112       if (.not. fm_get_value(name, array(i), index = i)) then  !{
1113         write (index_str,*) '(', i, ')'
1114         call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name) // trim(index_str))
1115       endif  !}
1116     enddo  !} i
1117   endif  !}
1118 elseif (fm_type .eq. ' ') then  !}{
1119   call mpp_error(FATAL, trim(error_header) // ' Array does not exist: ' // trim(name))
1120 else  !}{
1121  call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
1122 endif  !}
1123
1124 return
1125
1126 end function fm_util_get_string_array  !}
1127
1128 !#######################################################################
1129
1130 !> Get an integer value from the Field Manager tree.
1131 function fm_util_get_integer(name, caller, index, default_value, scalar)            &
1132          result (ival)  !{
1133
1134 implicit none
1135
1136 !
1137 !       Return type
1138 !
1139
1140 integer :: ival
1141
1142 !
1143 !       arguments
1144 !
1145
1146 character(len=*), intent(in)            :: name
1147 character(len=*), intent(in), optional  :: caller
1148 integer, intent(in), optional           :: index
1149 integer, intent(in), optional           :: default_value
1150 logical, intent(in), optional           :: scalar
1151
1152 !
1153 !       Local parameters
1154 !
1155
1156 character(len=48), parameter  :: sub_name = 'fm_util_get_integer'
1157
1158 !
1159 !       Local variables
1160 !
1161
1162 character(len=256)              :: error_header
1163 character(len=256)              :: warn_header
1164 character(len=256)              :: note_header
1165 character(len=128)              :: caller_str
1166 integer                         :: index_t
1167 character(len=fm_type_name_len) :: fm_type
1168 integer                         :: field_length
1169
1170 !
1171 !       set the caller string and headers
1172 !
1173
1174 if (present(caller)) then  !{
1175   caller_str = '[' // trim(caller) // ']'
1176 else  !}{
1177   caller_str = fm_util_default_caller
1178 endif  !}
1179
1180 error_header = '==>Error from ' // trim(mod_name) //   &
1181                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1182 warn_header = '==>Warning from ' // trim(mod_name) //  &
1183               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1184 note_header = '==>Note from ' // trim(mod_name) //     &
1185               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1186
1187 !
1188 !       check that a name is given (fatal if not)
1189 !
1190
1191 if (name .eq. ' ') then  !{
1192   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
1193 endif  !}
1194
1195 !
1196 !       Check whether we require a scalar (length=1) and return
1197 !       an error if we do, and it isn't
1198 !
1199
1200 if (present(scalar)) then  !{
1201   if (scalar) then  !{
1202     field_length = fm_get_length(name)
1203     if (field_length .lt. 0) then  !{
1204       call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
1205     elseif (field_length .gt. 1) then  !}{
1206       call mpp_error(FATAL, trim(error_header) // trim(name) // ' not scalar')
1207     endif  !}
1208   endif  !}
1209 endif  !}
1210
1211 !
1212 !       set the index
1213 !
1214
1215 if (present(index)) then  !{
1216   index_t = index
1217   if (index .le. 0) then  !{
1218     call mpp_error(FATAL, trim(error_header) // ' Index not positive')
1219   endif  !}
1220 else  !}{
1221   index_t = 1
1222 endif  !}
1223
1224 fm_type = fm_get_type(name)
1225 if (fm_type .eq. 'integer') then  !{
1226   if (.not. fm_get_value(name, ival, index = index_t)) then  !{
1227     call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name))
1228   endif  !}
1229 elseif (fm_type .eq. ' ' .and. present(default_value)) then  !}{
1230   ival = default_value
1231 elseif (fm_type .eq. ' ') then  !}{
1232   call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name))
1233 else  !}{
1234  call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
1235 endif  !}
1236
1237 return
1238
1239 end function fm_util_get_integer  !}
1240
1241 !#######################################################################
1242
1243 !> Get a logical value from the Field Manager tree.
1244 function fm_util_get_logical(name, caller, index, default_value, scalar)            &
1245          result (lval)  !{
1246
1247 implicit none
1248
1249 !
1250 !       Return type
1251 !
1252
1253 logical :: lval
1254
1255 !
1256 !       arguments
1257 !
1258
1259 character(len=*), intent(in)            :: name
1260 character(len=*), intent(in), optional  :: caller
1261 integer, intent(in), optional           :: index
1262 logical, intent(in), optional           :: default_value
1263 logical, intent(in), optional           :: scalar
1264
1265 !
1266 !       Local parameters
1267 !
1268
1269 character(len=48), parameter  :: sub_name = 'fm_util_get_logical'
1270
1271 !
1272 !       Local variables
1273 !
1274
1275 character(len=256)              :: error_header
1276 character(len=256)              :: warn_header
1277 character(len=256)              :: note_header
1278 character(len=128)              :: caller_str
1279 integer                         :: index_t
1280 character(len=fm_type_name_len) :: fm_type
1281 integer                         :: field_length
1282
1283 !
1284 !       set the caller string and headers
1285 !
1286
1287 if (present(caller)) then  !{
1288   caller_str = '[' // trim(caller) // ']'
1289 else  !}{
1290   caller_str = fm_util_default_caller
1291 endif  !}
1292
1293 error_header = '==>Error from ' // trim(mod_name) //   &
1294                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1295 warn_header = '==>Warning from ' // trim(mod_name) //  &
1296               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1297 note_header = '==>Note from ' // trim(mod_name) //     &
1298               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1299
1300 !
1301 !       check that a name is given (fatal if not)
1302 !
1303
1304 if (name .eq. ' ') then  !{
1305   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
1306 endif  !}
1307
1308 !
1309 !       Check whether we require a scalar (length=1) and return
1310 !       an error if we do, and it isn't
1311 !
1312
1313 if (present(scalar)) then  !{
1314   if (scalar) then  !{
1315     field_length = fm_get_length(name)
1316     if (field_length .lt. 0) then  !{
1317       call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
1318     elseif (field_length .gt. 1) then  !}{
1319       call mpp_error(FATAL, trim(error_header) // trim(name) // ' not scalar')
1320     endif  !}
1321   endif  !}
1322 endif  !}
1323
1324 !
1325 !       set the index
1326 !
1327
1328 if (present(index)) then  !{
1329   index_t = index
1330   if (index .le. 0) then  !{
1331     call mpp_error(FATAL, trim(error_header) // ' Index not positive')
1332   endif  !}
1333 else  !}{
1334   index_t = 1
1335 endif  !}
1336
1337 fm_type = fm_get_type(name)
1338 if (fm_type .eq. 'logical') then  !{
1339   if (.not. fm_get_value(name, lval, index = index_t)) then  !{
1340     call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name))
1341   endif  !}
1342 elseif (fm_type .eq. ' ' .and. present(default_value)) then  !}{
1343   lval = default_value
1344 elseif (fm_type .eq. ' ') then  !}{
1345   call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name))
1346 else  !}{
1347  call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
1348 endif  !}
1349
1350 return
1351
1352 end function fm_util_get_logical  !}
1353
1354 !#######################################################################
1355
1356
1357 !> Get a real value from the Field Manager tree.
1358 function fm_util_get_real(name, caller, index, default_value, scalar)           &
1359          result (rval)  !{
1360
1361 implicit none
1362
1363 !
1364 !       Return type
1365 !
1366
1367 real(r8_kind) :: rval
1368
1369 !
1370 !       arguments
1371 !
1372
1373 character(len=*), intent(in)            :: name
1374 character(len=*), intent(in), optional  :: caller
1375 integer, intent(in), optional           :: index
1376 real(r8_kind), intent(in), optional     :: default_value
1377 logical, intent(in), optional           :: scalar
1378
1379 !
1380 !       Local parameters
1381 !
1382
1383 character(len=48), parameter  :: sub_name = 'fm_util_get_real'
1384
1385 !
1386 !       Local variables
1387 !
1388
1389 character(len=256)              :: error_header
1390 character(len=256)              :: warn_header
1391 character(len=256)              :: note_header
1392 character(len=128)              :: caller_str
1393 integer                         :: index_t
1394 character(len=fm_type_name_len) :: fm_type
1395 integer                         :: field_length
1396 integer :: ivalue
1397
1398 !
1399 !       set the caller string and headers
1400 !
1401
1402 if (present(caller)) then  !{
1403   caller_str = '[' // trim(caller) // ']'
1404 else  !}{
1405   caller_str = fm_util_default_caller
1406 endif  !}
1407
1408 error_header = '==>Error from ' // trim(mod_name) //   &
1409                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1410 warn_header = '==>Warning from ' // trim(mod_name) //  &
1411               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1412 note_header = '==>Note from ' // trim(mod_name) //     &
1413               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1414
1415 !
1416 !       check that a name is given (fatal if not)
1417 !
1418
1419 if (name .eq. ' ') then  !{
1420   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
1421 endif  !}
1422
1423 !
1424 !       Check whether we require a scalar (length=1) and return
1425 !       an error if we do, and it isn't
1426 !
1427
1428 if (present(scalar)) then  !{
1429   if (scalar) then  !{
1430     field_length = fm_get_length(name)
1431     if (field_length .lt. 0) then  !{
1432       call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
1433     elseif (field_length .gt. 1) then  !}{
1434       call mpp_error(FATAL, trim(error_header) // trim(name) // ' not scalar')
1435     endif  !}
1436   endif  !}
1437 endif  !}
1438
1439 !
1440 !       set the index
1441 !
1442
1443 if (present(index)) then  !{
1444   index_t = index
1445   if (index .le. 0) then  !{
1446     call mpp_error(FATAL, trim(error_header) // ' Index not positive')
1447   endif  !}
1448 else  !}{
1449   index_t = 1
1450 endif  !}
1451
1452 fm_type = fm_get_type(name)
1453 if (fm_type .eq. 'real') then  !{
1454   if (.not. fm_get_value(name, rval, index = index_t)) then  !{
1455     call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name))
1456   endif  !}
1457 else if (fm_type .eq. 'integer') then
1458   if (.not. fm_get_value(name, ivalue, index = index_t)) then
1459     call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name))
1460   endif
1461   rval = real(ivalue,r8_kind)
1462 elseif (fm_type .eq. ' ' .and. present(default_value)) then  !}{
1463   rval = default_value
1464 elseif (fm_type .eq. ' ') then  !}{
1465   call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name))
1466 else  !}{
1467  call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
1468 endif  !}
1469
1470 return
1471
1472 end function fm_util_get_real  !}
1473
1474
1475 !#######################################################################
1476
1477
1478 !> Get a string value from the Field Manager tree.
1479 function fm_util_get_string(name, caller, index, default_value, scalar)            &
1480          result (sval)  !{
1481
1482 implicit none
1483
1484 !
1485 !       Return type
1486 !
1487
1488 character(len=fm_string_len) :: sval
1489
1490 !
1491 !       arguments
1492 !
1493
1494 character(len=*), intent(in)            :: name
1495 character(len=*), intent(in), optional  :: caller
1496 integer, intent(in), optional           :: index
1497 character(len=*), intent(in), optional  :: default_value
1498 logical, intent(in), optional           :: scalar
1499
1500 !
1501 !       Local parameters
1502 !
1503
1504 character(len=48), parameter  :: sub_name = 'fm_util_get_string'
1505
1506 !
1507 !       Local variables
1508 !
1509
1510 character(len=256)              :: error_header
1511 character(len=256)              :: warn_header
1512 character(len=256)              :: note_header
1513 character(len=128)              :: caller_str
1514 integer                         :: index_t
1515 character(len=fm_type_name_len) :: fm_type
1516 integer                         :: field_length
1517
1518 !
1519 !       set the caller string and headers
1520 !
1521
1522 if (present(caller)) then  !{
1523   caller_str = '[' // trim(caller) // ']'
1524 else  !}{
1525   caller_str = fm_util_default_caller
1526 endif  !}
1527
1528 error_header = '==>Error from ' // trim(mod_name) //   &
1529                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1530 warn_header = '==>Warning from ' // trim(mod_name) //  &
1531               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1532 note_header = '==>Note from ' // trim(mod_name) //     &
1533               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1534
1535 !
1536 !       check that a name is given (fatal if not)
1537 !
1538
1539 if (name .eq. ' ') then  !{
1540   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
1541 endif  !}
1542
1543 !
1544 !       Check whether we require a scalar (length=1) and return
1545 !       an error if we do, and it isn't
1546 !
1547
1548 if (present(scalar)) then  !{
1549   if (scalar) then  !{
1550     field_length = fm_get_length(name)
1551     if (field_length .lt. 0) then  !{
1552       call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
1553     elseif (field_length .gt. 1) then  !}{
1554       call mpp_error(FATAL, trim(error_header) // trim(name) // ' not scalar')
1555     endif  !}
1556   endif  !}
1557 endif  !}
1558
1559 !
1560 !       set the index
1561 !
1562
1563 if (present(index)) then  !{
1564   index_t = index
1565   if (index .le. 0) then  !{
1566     call mpp_error(FATAL, trim(error_header) // ' Index not positive')
1567   endif  !}
1568 else  !}{
1569   index_t = 1
1570 endif  !}
1571
1572 fm_type = fm_get_type(name)
1573 if (fm_type .eq. 'string') then  !{
1574   if (.not. fm_get_value(name, sval, index = index_t)) then  !{
1575     call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name))
1576   endif  !}
1577 elseif (fm_type .eq. ' ' .and. present(default_value)) then  !}{
1578   sval = default_value
1579 elseif (fm_type .eq. ' ') then  !}{
1580   call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name))
1581 else  !}{
1582  call mpp_error(FATAL, trim(error_header) // ' Wrong type for ' // trim(name) // ', found (' // trim(fm_type) // ')')
1583 endif  !}
1584
1585 return
1586
1587 end function fm_util_get_string  !}
1588
1589 !#######################################################################
1590
1591 !> Set an integer array in the Field Manager tree.
1592 subroutine fm_util_set_value_integer_array(name, ival, length, caller, no_overwrite, good_name_list)  !{
1593
1594 implicit none
1595
1596 !
1597 !       arguments
1598 !
1599
1600 character(len=*), intent(in)                            :: name
1601 integer, intent(in)                                     :: length
1602 integer, intent(in)                                     :: ival(length)
1603 character(len=*), intent(in), optional                  :: caller
1604 logical, intent(in), optional                           :: no_overwrite
1605 character(len=*), intent(in), optional                  :: good_name_list
1606
1607 !
1608 !       Local parameters
1609 !
1610
1611 character(len=48), parameter    :: sub_name = 'fm_util_set_value_integer_array'
1612
1613 !
1614 !       Local variables
1615 !
1616
1617 character(len=256)              :: error_header
1618 character(len=256)              :: warn_header
1619 character(len=256)              :: note_header
1620 character(len=128)              :: caller_str
1621 character(len=32)               :: str_error
1622 integer                         :: field_index
1623 integer                         :: field_length
1624 integer                         :: n
1625 logical                         :: no_overwrite_use
1626 character(len=FMS_PATH_LEN)     :: good_name_list_use
1627 logical                         :: add_name
1628
1629 !
1630 !       set the caller string and headers
1631 !
1632
1633 if (present(caller)) then  !{
1634   caller_str = '[' // trim(caller) // ']'
1635 else  !}{
1636   caller_str = fm_util_default_caller
1637 endif  !}
1638
1639 error_header = '==>Error from ' // trim(mod_name) //   &
1640                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1641 warn_header = '==>Warning from ' // trim(mod_name) //  &
1642               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1643 note_header = '==>Note from ' // trim(mod_name) //     &
1644               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1645
1646 !
1647 !       check that a name is given (fatal if not)
1648 !
1649
1650 if (name .eq. ' ') then  !{
1651   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
1652 endif  !}
1653
1654 !
1655 !       check that the length is non-negative
1656 !
1657
1658 if (length .lt. 0) then  !{
1659   call mpp_error(FATAL, trim(error_header) // ' Negative array length')
1660 endif  !}
1661
1662 !
1663 !       check for whether to overwrite existing values
1664 !
1665
1666 if (present(no_overwrite)) then  !{
1667   no_overwrite_use = no_overwrite
1668 else  !}{
1669   no_overwrite_use = default_no_overwrite
1670 endif  !}
1671
1672 !
1673 !       check for whether to save the name in a list
1674 !
1675
1676 if (present(good_name_list)) then  !{
1677   good_name_list_use = good_name_list
1678 else  !}{
1679   good_name_list_use = default_good_name_list
1680 endif  !}
1681
1682 !
1683 !       write the data array
1684 !
1685
1686 if (length .eq. 0) then  !{
1687   if (.not. (no_overwrite_use .and. fm_exists(name))) then  !{
1688     field_index = fm_new_value(name, 0, index = 0)
1689     if (field_index .le. 0) then  !{
1690       write (str_error,*) ' with length = ', length
1691       call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
1692     endif  !}
1693   endif  !}
1694 else  !}{
1695   if (no_overwrite_use .and. fm_exists(name)) then  !{
1696     field_length = fm_get_length(name)
1697     if (field_length .lt. 0) then  !{
1698       call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
1699     endif  !}
1700     do n = field_length + 1, length  !{
1701       field_index = fm_new_value(name, ival(n), index = n)
1702       if (field_index .le. 0) then  !{
1703         write (str_error,*) ' with index = ', n
1704         call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
1705       endif  !}
1706     enddo  !} n
1707   else  !}{
1708     field_index = fm_new_value(name, ival(1))
1709     if (field_index .le. 0) then  !{
1710       call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name))
1711     endif  !}
1712     do n = 2, length  !{
1713       field_index = fm_new_value(name, ival(n), index = n)
1714       if (field_index .le. 0) then  !{
1715         write (str_error,*) ' with index = ', n
1716         call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
1717       endif  !}
1718     enddo  !} n
1719   endif  !}
1720 endif  !}
1721
1722 !
1723 !       Add the variable name to the list of good names, to be used
1724 !       later for a consistency check
1725 !
1726
1727 if (good_name_list_use .ne. ' ') then  !{
1728   if (fm_exists(good_name_list_use)) then  !{
1729     add_name = fm_util_get_index_string(good_name_list_use, name,               &
1730        caller = caller_str) .le. 0              ! true if name does not exist in string array
1731   else  !}{
1732     add_name = .true.                           ! always add to new list
1733   endif  !}
1734   if (add_name .and. fm_exists(name)) then  !{
1735     if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
1736       call mpp_error(FATAL, trim(error_header) //                               &
1737            ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
1738     endif  !}
1739   endif  !}
1740 endif  !}
1741
1742 return
1743
1744 end subroutine fm_util_set_value_integer_array  !}
1745
1746 !#######################################################################
1747
1748 !> Set a logical array in the Field Manager tree.
1749 subroutine fm_util_set_value_logical_array(name, lval, length, caller, no_overwrite, good_name_list)  !{
1750
1751 implicit none
1752
1753 !
1754 !       arguments
1755 !
1756
1757 character(len=*), intent(in)                            :: name
1758 integer, intent(in)                                     :: length
1759 logical, intent(in)                                     :: lval(length)
1760 character(len=*), intent(in), optional                  :: caller
1761 logical, intent(in), optional                           :: no_overwrite
1762 character(len=*), intent(in), optional                  :: good_name_list
1763
1764 !
1765 !       Local parameters
1766 !
1767
1768 character(len=48), parameter    :: sub_name = 'fm_util_set_value_logical_array'
1769
1770 !
1771 !       Local variables
1772 !
1773
1774 character(len=256)              :: error_header
1775 character(len=256)              :: warn_header
1776 character(len=256)              :: note_header
1777 character(len=128)              :: caller_str
1778 character(len=32)               :: str_error
1779 integer                         :: field_index
1780 integer                         :: field_length
1781 integer                         :: n
1782 logical                         :: no_overwrite_use
1783 character(len=FMS_PATH_LEN)     :: good_name_list_use
1784 logical                         :: add_name
1785
1786 !
1787 !       set the caller string and headers
1788 !
1789
1790 if (present(caller)) then  !{
1791   caller_str = '[' // trim(caller) // ']'
1792 else  !}{
1793   caller_str = fm_util_default_caller
1794 endif  !}
1795
1796 error_header = '==>Error from ' // trim(mod_name) //   &
1797                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1798 warn_header = '==>Warning from ' // trim(mod_name) //  &
1799               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1800 note_header = '==>Note from ' // trim(mod_name) //     &
1801               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1802
1803 !
1804 !       check that a name is given (fatal if not)
1805 !
1806
1807 if (name .eq. ' ') then  !{
1808   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
1809 endif  !}
1810
1811 !
1812 !       check that the length is non-negative
1813 !
1814
1815 if (length .lt. 0) then  !{
1816   call mpp_error(FATAL, trim(error_header) // ' Negative array length')
1817 endif  !}
1818
1819 !
1820 !       check for whether to overwrite existing values
1821 !
1822
1823 if (present(no_overwrite)) then  !{
1824   no_overwrite_use = no_overwrite
1825 else  !}{
1826   no_overwrite_use = default_no_overwrite
1827 endif  !}
1828
1829 !
1830 !       check for whether to save the name in a list
1831 !
1832
1833 if (present(good_name_list)) then  !{
1834   good_name_list_use = good_name_list
1835 else  !}{
1836   good_name_list_use = default_good_name_list
1837 endif  !}
1838
1839 !
1840 !       write the data array
1841 !
1842
1843 if (length .eq. 0) then  !{
1844   if (.not. (no_overwrite_use .and. fm_exists(name))) then  !{
1845     field_index = fm_new_value(name, .false., index = 0)
1846     if (field_index .le. 0) then  !{
1847       write (str_error,*) ' with length = ', length
1848       call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
1849     endif  !}
1850   endif  !}
1851 else  !}{
1852   if (no_overwrite_use .and. fm_exists(name)) then  !{
1853     field_length = fm_get_length(name)
1854     if (field_length .lt. 0) then  !{
1855       call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
1856     endif  !}
1857     do n = field_length + 1, length  !{
1858       field_index = fm_new_value(name, lval(n), index = n)
1859       if (field_index .le. 0) then  !{
1860         write (str_error,*) ' with index = ', n
1861         call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
1862       endif  !}
1863     enddo  !} n
1864   else  !}{
1865     field_index = fm_new_value(name, lval(1))
1866     if (field_index .le. 0) then  !{
1867       call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name))
1868     endif  !}
1869     do n = 2, length  !{
1870       field_index = fm_new_value(name, lval(n), index = n)
1871       if (field_index .le. 0) then  !{
1872         write (str_error,*) ' with index = ', n
1873         call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
1874       endif  !}
1875     enddo  !} n
1876   endif  !}
1877 endif  !}
1878
1879 !
1880 !       Add the variable name to the list of good names, to be used
1881 !       later for a consistency check
1882 !
1883
1884 if (good_name_list_use .ne. ' ') then  !{
1885   if (fm_exists(good_name_list_use)) then  !{
1886     add_name = fm_util_get_index_string(good_name_list_use, name,               &
1887        caller = caller_str) .le. 0              ! true if name does not exist in string array
1888   else  !}{
1889     add_name = .true.                           ! always add to new list
1890   endif  !}
1891   if (add_name .and. fm_exists(name)) then  !{
1892     if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
1893       call mpp_error(FATAL, trim(error_header) //                               &
1894            ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
1895     endif  !}
1896   endif  !}
1897 endif  !}
1898
1899 return
1900
1901 end subroutine fm_util_set_value_logical_array  !}
1902
1903 !#######################################################################
1904
1905 !> Set a string array in the Field Manager tree.
1906 subroutine fm_util_set_value_string_array(name, sval, length, caller, no_overwrite, good_name_list)  !{
1907
1908 implicit none
1909
1910 !
1911 !       arguments
1912 !
1913
1914 character(len=*), intent(in)                            :: name
1915 integer, intent(in)                                     :: length
1916 character(len=*), intent(in)                            :: sval(length)
1917 character(len=*), intent(in), optional                  :: caller
1918 logical, intent(in), optional                           :: no_overwrite
1919 character(len=*), intent(in), optional       :: good_name_list
1920
1921 !
1922 !       Local parameters
1923 !
1924
1925 character(len=48), parameter    :: sub_name = 'fm_util_set_value_string_array'
1926
1927 !
1928 !       Local variables
1929 !
1930
1931 character(len=256)              :: error_header
1932 character(len=256)              :: warn_header
1933 character(len=256)              :: note_header
1934 character(len=128)              :: caller_str
1935 character(len=32)               :: str_error
1936 integer                         :: field_index
1937 integer                         :: field_length
1938 integer                         :: n
1939 logical                         :: no_overwrite_use
1940 character(len=FMS_PATH_LEN)     :: good_name_list_use
1941 logical                         :: add_name
1942
1943 !
1944 !       set the caller string and headers
1945 !
1946
1947 if (present(caller)) then  !{
1948   caller_str = '[' // trim(caller) // ']'
1949 else  !}{
1950   caller_str = fm_util_default_caller
1951 endif  !}
1952
1953 error_header = '==>Error from ' // trim(mod_name) //   &
1954                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1955 warn_header = '==>Warning from ' // trim(mod_name) //  &
1956               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1957 note_header = '==>Note from ' // trim(mod_name) //     &
1958               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
1959
1960 !
1961 !       check that a name is given (fatal if not)
1962 !
1963
1964 if (name .eq. ' ') then  !{
1965   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
1966 endif  !}
1967
1968 !
1969 !       check that the length is non-negative
1970 !
1971
1972 if (length .lt. 0) then  !{
1973   call mpp_error(FATAL, trim(error_header) // ' Negative array length')
1974 endif  !}
1975
1976 !
1977 !       check for whether to overwrite existing values
1978 !
1979
1980 if (present(no_overwrite)) then  !{
1981   no_overwrite_use = no_overwrite
1982 else  !}{
1983   no_overwrite_use = default_no_overwrite
1984 endif  !}
1985
1986 !
1987 !       check for whether to save the name in a list
1988 !
1989
1990 if (present(good_name_list)) then  !{
1991   good_name_list_use = good_name_list
1992 else  !}{
1993   good_name_list_use = default_good_name_list
1994 endif  !}
1995
1996 !
1997 !       write the data array
1998 !
1999
2000 if (length .eq. 0) then  !{
2001   if (.not. (no_overwrite_use .and. fm_exists(name))) then  !{
2002     field_index = fm_new_value(name, ' ', index = 0)
2003     if (field_index .le. 0) then  !{
2004       write (str_error,*) ' with length = ', length
2005       call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
2006     endif  !}
2007   endif  !}
2008 else  !}{
2009   if (no_overwrite_use .and. fm_exists(name)) then  !{
2010     field_length = fm_get_length(name)
2011     if (field_length .lt. 0) then  !{
2012       call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
2013     endif  !}
2014     do n = field_length + 1, length  !{
2015       field_index = fm_new_value(name, sval(n), index = n)
2016       if (field_index .le. 0) then  !{
2017         write (str_error,*) ' with index = ', n
2018         call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
2019       endif  !}
2020     enddo  !} n
2021   else  !}{
2022     field_index = fm_new_value(name, sval(1))
2023     if (field_index .le. 0) then  !{
2024       call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name))
2025     endif  !}
2026     do n = 2, length  !{
2027       field_index = fm_new_value(name, sval(n), index = n)
2028       if (field_index .le. 0) then  !{
2029         write (str_error,*) ' with index = ', n
2030         call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
2031       endif  !}
2032     enddo  !} n
2033   endif  !}
2034 endif  !}
2035
2036 !
2037 !       Add the variable name to the list of good names, to be used
2038 !       later for a consistency check
2039 !
2040
2041 if (good_name_list_use .ne. ' ') then  !{
2042   if (fm_exists(good_name_list_use)) then  !{
2043     add_name = fm_util_get_index_string(good_name_list_use, name,               &
2044        caller = caller_str) .le. 0              ! true if name does not exist in string array
2045   else  !}{
2046     add_name = .true.                           ! always add to new list
2047   endif  !}
2048   if (add_name .and. fm_exists(name)) then  !{
2049     if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
2050       call mpp_error(FATAL, trim(error_header) //                               &
2051            ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
2052     endif  !}
2053   endif  !}
2054 endif  !}
2055
2056 return
2057
2058 end subroutine fm_util_set_value_string_array  !}
2059
2060 !#######################################################################
2061
2062 !> Set an integer value in the Field Manager tree.
2063 subroutine fm_util_set_value_integer(name, ival, caller, index, append, no_create,        &
2064      no_overwrite, good_name_list)  !{
2065
2066 implicit none
2067
2068 !
2069 !       arguments
2070 !
2071
2072 character(len=*), intent(in)            :: name
2073 integer, intent(in)                     :: ival
2074 character(len=*), intent(in), optional  :: caller
2075 integer, intent(in), optional           :: index
2076 logical, intent(in), optional           :: append
2077 logical, intent(in), optional           :: no_create
2078 logical, intent(in), optional           :: no_overwrite
2079 character(len=*), intent(in), optional  :: good_name_list
2080
2081 !
2082 !       Local parameters
2083 !
2084
2085 character(len=48), parameter    :: sub_name = 'fm_util_set_value_integer'
2086
2087 !
2088 !       Local variables
2089 !
2090
2091 character(len=256)              :: error_header
2092 character(len=256)              :: warn_header
2093 character(len=256)              :: note_header
2094 character(len=128)              :: caller_str
2095 character(len=32)               :: str_error
2096 integer                         :: field_index
2097 logical                         :: no_overwrite_use
2098 integer                         :: field_length
2099 character(len=FMS_PATH_LEN)     :: good_name_list_use
2100 logical                         :: create
2101 logical                         :: add_name
2102
2103 !
2104 !       set the caller string and headers
2105 !
2106
2107 if (present(caller)) then  !{
2108   caller_str = '[' // trim(caller) // ']'
2109 else  !}{
2110   caller_str = fm_util_default_caller
2111 endif  !}
2112
2113 error_header = '==>Error from ' // trim(mod_name) //   &
2114                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2115 warn_header = '==>Warning from ' // trim(mod_name) //  &
2116               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2117 note_header = '==>Note from ' // trim(mod_name) //     &
2118               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2119
2120 !
2121 !       check that a name is given (fatal if not)
2122 !
2123
2124 if (name .eq. ' ') then  !{
2125   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
2126 endif  !}
2127
2128 !
2129 !       check that append and index are not both given
2130 !
2131
2132 if (present(index) .and. present(append)) then  !{
2133   call mpp_error(FATAL, trim(error_header) // ' Append and index both given as arguments')
2134 endif  !}
2135
2136 !
2137 !       check for whether to overwrite existing values
2138 !
2139
2140 if (present(no_overwrite)) then  !{
2141   no_overwrite_use = no_overwrite
2142 else  !}{
2143   no_overwrite_use = default_no_overwrite
2144 endif  !}
2145
2146 !
2147 !       check for whether to save the name in a list
2148 !
2149
2150 if (present(good_name_list)) then  !{
2151   good_name_list_use = good_name_list
2152 else  !}{
2153   good_name_list_use = default_good_name_list
2154 endif  !}
2155
2156 if (present(no_create)) then  !{
2157   create = .not. no_create
2158   if (no_create .and. (present(append) .or. present(index))) then  !{
2159     call mpp_error(FATAL, trim(error_header) // &
2160                    &  ' append or index are present when no_create is true for ' // trim(name))
2161   endif  !}
2162 else  !}{
2163   create = .true.
2164 endif  !}
2165
2166 if (present(index)) then  !{
2167   if (fm_exists(name)) then  !{
2168     field_length = fm_get_length(name)
2169     if (field_length .lt. 0) then  !{
2170       call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
2171     endif  !}
2172     if (.not. (no_overwrite_use .and. field_length .ge. index)) then  !{
2173       field_index = fm_new_value(name, ival, index = index)
2174       if (field_index .le. 0) then  !{
2175         write (str_error,*) ' with index = ', index
2176         call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error))
2177       endif  !}
2178     endif  !}
2179   else  !}{
2180     field_index = fm_new_value(name, ival, index = index)
2181     if (field_index .le. 0) then  !{
2182       write (str_error,*) ' with index = ', index
2183       call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
2184     endif  !}
2185   endif  !}
2186 elseif (present(append)) then  !}{
2187   field_index = fm_new_value(name, ival, append = append)
2188   if (field_index .le. 0) then  !{
2189     write (str_error,*) ' with append = ', append
2190     call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
2191   endif  !}
2192 else  !}{
2193   if (fm_exists(name)) then  !{
2194     if (.not. no_overwrite_use) then  !{
2195       field_index = fm_new_value(name, ival)
2196       if (field_index .le. 0) then  !{
2197         call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name))
2198       endif  !}
2199     endif  !}
2200   elseif (create) then  !}{
2201     field_index = fm_new_value(name, ival)
2202     if (field_index .le. 0) then  !{
2203       call mpp_error(FATAL, trim(error_header) // ' Problem creating ' // trim(name))
2204     endif  !}
2205   endif  !}
2206 endif  !}
2207
2208 !
2209 !       Add the variable name to the list of good names, to be used
2210 !       later for a consistency check, unless the field did not exist and we did not create it
2211 !
2212
2213 if (good_name_list_use .ne. ' ') then  !{
2214   if (fm_exists(good_name_list_use)) then  !{
2215     add_name = fm_util_get_index_string(good_name_list_use, name,               &
2216        caller = caller_str) .le. 0              ! true if name does not exist in string array
2217   else  !}{
2218     add_name = .true.                           ! always add to new list
2219   endif  !}
2220   if (add_name .and. fm_exists(name)) then  !{
2221     if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
2222       call mpp_error(FATAL, trim(error_header) //                               &
2223            ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
2224     endif  !}
2225   endif  !}
2226 endif  !}
2227
2228 return
2229
2230 end subroutine fm_util_set_value_integer  !}
2231
2232 !#######################################################################
2233
2234 !> Set a logical value in the Field Manager tree.
2235 subroutine fm_util_set_value_logical(name, lval, caller, index, append, no_create,        &
2236      no_overwrite, good_name_list)  !{
2237
2238 implicit none
2239
2240 !
2241 !       arguments
2242 !
2243
2244 character(len=*), intent(in)            :: name
2245 logical, intent(in)                     :: lval
2246 character(len=*), intent(in), optional  :: caller
2247 integer, intent(in), optional           :: index
2248 logical, intent(in), optional           :: append
2249 logical, intent(in), optional           :: no_create
2250 logical, intent(in), optional           :: no_overwrite
2251 character(len=*), intent(in), optional  :: good_name_list
2252
2253 !
2254 !       Local parameters
2255 !
2256
2257 character(len=48), parameter    :: sub_name = 'fm_util_set_value_logical'
2258
2259 !
2260 !       Local variables
2261 !
2262
2263 character(len=256)              :: error_header
2264 character(len=256)              :: warn_header
2265 character(len=256)              :: note_header
2266 character(len=128)              :: caller_str
2267 character(len=32)               :: str_error
2268 integer                         :: field_index
2269 logical                         :: no_overwrite_use
2270 integer                         :: field_length
2271 character(len=FMS_PATH_LEN)     :: good_name_list_use
2272 logical                         :: create
2273 logical                         :: add_name
2274
2275 !
2276 !       set the caller string and headers
2277 !
2278
2279 if (present(caller)) then  !{
2280   caller_str = '[' // trim(caller) // ']'
2281 else  !}{
2282   caller_str = fm_util_default_caller
2283 endif  !}
2284
2285 error_header = '==>Error from ' // trim(mod_name) //   &
2286                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2287 warn_header = '==>Warning from ' // trim(mod_name) //  &
2288               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2289 note_header = '==>Note from ' // trim(mod_name) //     &
2290               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2291
2292 !
2293 !       check that a name is given (fatal if not)
2294 !
2295
2296 if (name .eq. ' ') then  !{
2297   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
2298 endif  !}
2299
2300 !
2301 !       check that append and index are not both given
2302 !
2303
2304 if (present(index) .and. present(append)) then  !{
2305   call mpp_error(FATAL, trim(error_header) // ' Append and index both given as arguments')
2306 endif  !}
2307
2308 !
2309 !       check for whether to overwrite existing values
2310 !
2311
2312 if (present(no_overwrite)) then  !{
2313   no_overwrite_use = no_overwrite
2314 else  !}{
2315   no_overwrite_use = default_no_overwrite
2316 endif  !}
2317
2318 !
2319 !       check for whether to save the name in a list
2320 !
2321
2322 if (present(good_name_list)) then  !{
2323   good_name_list_use = good_name_list
2324 else  !}{
2325   good_name_list_use = default_good_name_list
2326 endif  !}
2327
2328 if (present(no_create)) then  !{
2329   create = .not. no_create
2330   if (no_create .and. (present(append) .or. present(index))) then  !{
2331     call mpp_error(FATAL, trim(error_header) // &
2332                    &  ' append or index are present when no_create is true for ' // trim(name))
2333   endif  !}
2334 else  !}{
2335   create = .true.
2336 endif  !}
2337
2338 if (present(index)) then  !{
2339   if (fm_exists(name)) then  !{
2340     field_length = fm_get_length(name)
2341     if (field_length .lt. 0) then  !{
2342       call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
2343     endif  !}
2344     if (.not. (no_overwrite_use .and. field_length .ge. index)) then  !{
2345       field_index = fm_new_value(name, lval, index = index)
2346       if (field_index .le. 0) then  !{
2347         write (str_error,*) ' with index = ', index
2348         call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error))
2349       endif  !}
2350     endif  !}
2351   else  !}{
2352     field_index = fm_new_value(name, lval, index = index)
2353     if (field_index .le. 0) then  !{
2354       write (str_error,*) ' with index = ', index
2355       call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
2356     endif  !}
2357   endif  !}
2358 elseif (present(append)) then  !}{
2359   field_index = fm_new_value(name, lval, append = append)
2360   if (field_index .le. 0) then  !{
2361     write (str_error,*) ' with append = ', append
2362     call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
2363   endif  !}
2364 else  !}{
2365   if (fm_exists(name)) then  !{
2366     if (.not. no_overwrite_use) then  !{
2367       field_index = fm_new_value(name, lval)
2368       if (field_index .le. 0) then  !{
2369         call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name))
2370       endif  !}
2371     endif  !}
2372   elseif (create) then  !}{
2373     field_index = fm_new_value(name, lval)
2374     if (field_index .le. 0) then  !{
2375       call mpp_error(FATAL, trim(error_header) // ' Problem creating ' // trim(name))
2376     endif  !}
2377   endif  !}
2378 endif  !}
2379
2380 !
2381 !       Add the variable name to the list of good names, to be used
2382 !       later for a consistency check, unless the field did not exist and we did not create it
2383 !
2384
2385 if (good_name_list_use .ne. ' ') then  !{
2386   if (fm_exists(good_name_list_use)) then  !{
2387     add_name = fm_util_get_index_string(good_name_list_use, name,               &
2388        caller = caller_str) .le. 0              ! true if name does not exist in string array
2389   else  !}{
2390     add_name = .true.                           ! always add to new list
2391   endif  !}
2392   if (add_name .and. fm_exists(name)) then  !{
2393     if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
2394       call mpp_error(FATAL, trim(error_header) //                               &
2395            ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
2396     endif  !}
2397   endif  !}
2398 endif  !}
2399
2400 return
2401
2402 end subroutine fm_util_set_value_logical  !}
2403
2404 !#######################################################################
2405 !> Set a string value in the Field Manager tree.
2406 subroutine fm_util_set_value_string(name, sval, caller, index, append, no_create,        &
2407      no_overwrite, good_name_list)  !{
2408
2409 implicit none
2410
2411 !
2412 !       arguments
2413 !
2414
2415 character(len=*), intent(in)            :: name
2416 character(len=*), intent(in)            :: sval
2417 character(len=*), intent(in), optional  :: caller
2418 integer, intent(in), optional           :: index
2419 logical, intent(in), optional           :: append
2420 logical, intent(in), optional           :: no_create
2421 logical, intent(in), optional           :: no_overwrite
2422 character(len=*), intent(in), optional  :: good_name_list
2423
2424 !
2425 !       Local parameters
2426 !
2427
2428 character(len=48), parameter    :: sub_name = 'fm_util_set_value_string'
2429
2430 !
2431 !       Local variables
2432 !
2433
2434 character(len=256)              :: error_header
2435 character(len=256)              :: warn_header
2436 character(len=256)              :: note_header
2437 character(len=128)              :: caller_str
2438 character(len=32)               :: str_error
2439 integer                         :: field_index
2440 logical                         :: no_overwrite_use
2441 integer                         :: field_length
2442 character(len=FMS_PATH_LEN)     :: good_name_list_use
2443 logical                         :: create
2444 logical                         :: add_name
2445
2446 !
2447 !       set the caller string and headers
2448 !
2449
2450 if (present(caller)) then  !{
2451   caller_str = '[' // trim(caller) // ']'
2452 else  !}{
2453   caller_str = fm_util_default_caller
2454 endif  !}
2455
2456 error_header = '==>Error from ' // trim(mod_name) //   &
2457                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2458 warn_header = '==>Warning from ' // trim(mod_name) //  &
2459               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2460 note_header = '==>Note from ' // trim(mod_name) //     &
2461               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2462
2463 !
2464 !       check that a name is given (fatal if not)
2465 !
2466
2467 if (name .eq. ' ') then  !{
2468   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
2469 endif  !}
2470
2471 !
2472 !       check that append and index are not both given
2473 !
2474
2475 if (present(index) .and. present(append)) then  !{
2476   call mpp_error(FATAL, trim(error_header) // ' Append and index both given as arguments')
2477 endif  !}
2478
2479 !
2480 !       check for whether to overwrite existing values
2481 !
2482
2483 if (present(no_overwrite)) then  !{
2484   no_overwrite_use = no_overwrite
2485 else  !}{
2486   no_overwrite_use = default_no_overwrite
2487 endif  !}
2488
2489 !
2490 !       check for whether to save the name in a list
2491 !
2492
2493 if (present(good_name_list)) then  !{
2494   good_name_list_use = good_name_list
2495 else  !}{
2496   good_name_list_use = default_good_name_list
2497 endif  !}
2498
2499 if (present(no_create)) then  !{
2500   create = .not. no_create
2501   if (no_create .and. (present(append) .or. present(index))) then  !{
2502     call mpp_error(FATAL, trim(error_header) // &
2503                    &  ' append or index are present when no_create is true for ' // trim(name))
2504   endif  !}
2505 else  !}{
2506   create = .true.
2507 endif  !}
2508
2509 if (present(index)) then  !{
2510   if (fm_exists(name)) then  !{
2511     field_length = fm_get_length(name)
2512     if (field_length .lt. 0) then  !{
2513       call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name))
2514     endif  !}
2515     if (.not. (no_overwrite_use .and. field_length .ge. index)) then  !{
2516       field_index = fm_new_value(name, sval, index = index)
2517       if (field_index .le. 0) then  !{
2518         write (str_error,*) ' with index = ', index
2519         call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error))
2520       endif  !}
2521     endif  !}
2522   else  !}{
2523     field_index = fm_new_value(name, sval, index = index)
2524     if (field_index .le. 0) then  !{
2525       write (str_error,*) ' with index = ', index
2526       call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
2527     endif  !}
2528   endif  !}
2529 elseif (present(append)) then  !}{
2530   field_index = fm_new_value(name, sval, append = append)
2531   if (field_index .le. 0) then  !{
2532     write (str_error,*) ' with append = ', append
2533     call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
2534   endif  !}
2535 else  !}{
2536   if (fm_exists(name)) then  !{
2537     if (.not. no_overwrite_use) then  !{
2538       field_index = fm_new_value(name, sval)
2539       if (field_index .le. 0) then  !{
2540         call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name))
2541       endif  !}
2542     endif  !}
2543   elseif (create) then  !}{
2544     field_index = fm_new_value(name, sval)
2545     if (field_index .le. 0) then  !{
2546       call mpp_error(FATAL, trim(error_header) // ' Problem creating ' // trim(name))
2547     endif  !}
2548   endif  !}
2549 endif  !}
2550
2551 !
2552 !       Add the variable name to the list of good names, to be used
2553 !       later for a consistency check, unless the field did not exist and we did not create it
2554 !
2555
2556 if (good_name_list_use .ne. ' ') then  !{
2557   if (fm_exists(good_name_list_use)) then  !{
2558     add_name = fm_util_get_index_string(good_name_list_use, name,               &
2559        caller = caller_str) .le. 0              ! true if name does not exist in string array
2560   else  !}{
2561     add_name = .true.                           ! always add to new list
2562   endif  !}
2563   if (add_name .and. fm_exists(name)) then  !{
2564     if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then  !{
2565       call mpp_error(FATAL, trim(error_header) //                               &
2566            ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
2567     endif  !}
2568   endif  !}
2569 endif  !}
2570
2571 return
2572
2573 end subroutine fm_util_set_value_string  !}
2574
2575 !#######################################################################
2576
2577 !> Start processing a namelist
2578 subroutine fm_util_start_namelist(path, name, caller, no_overwrite, check)  !{
2579
2580 implicit none
2581
2582 !
2583 !       arguments
2584 !
2585
2586 character(len=*), intent(in)            :: path
2587 character(len=*), intent(in)            :: name
2588 character(len=*), intent(in), optional  :: caller
2589 logical,          intent(in), optional  :: no_overwrite
2590 logical,          intent(in), optional  :: check
2591
2592 !
2593 !       Local parameters
2594 !
2595
2596 character(len=48), parameter  :: sub_name = 'fm_util_start_namelist'
2597
2598 !
2599 !       Local variables
2600 !
2601
2602 integer                         :: namelist_index
2603 character(len=FMS_PATH_LEN)     :: path_name
2604 character(len=256)              :: error_header
2605 character(len=256)              :: warn_header
2606 character(len=256)              :: note_header
2607 character(len=128)              :: caller_str
2608 integer                         :: out_unit
2609
2610 out_unit = stdout()
2611
2612 !
2613 !       set the caller string and headers
2614 !
2615
2616 if (present(caller)) then  !{
2617   caller_str = '[' // trim(caller) // ']'
2618 else  !}{
2619   caller_str = fm_util_default_caller
2620 endif  !}
2621
2622 error_header = '==>Error from ' // trim(mod_name) //   &
2623                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2624 warn_header = '==>Warning from ' // trim(mod_name) //  &
2625               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2626 note_header = '==>Note from ' // trim(mod_name) //     &
2627               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2628
2629 !
2630 !       check that a name is given (fatal if not)
2631 !
2632
2633 if (name .eq. ' ') then  !{
2634   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
2635 endif  !}
2636
2637 !
2638 !       Concatenate the path and name
2639 !
2640
2641 if (path .eq. ' ') then  !{
2642   path_name = name
2643 else  !}{
2644   path_name = trim(path) // '/' // name
2645 endif  !}
2646 save_path = path
2647 save_name = name
2648
2649 !
2650 !       set the default caller string, if desired
2651 !
2652
2653 if (present(caller)) then  !{
2654   call fm_util_set_caller(caller)
2655 else  !}{
2656   call fm_util_reset_caller
2657 endif  !}
2658
2659 !
2660 !       set the default no_overwrite flag, if desired
2661 !
2662
2663 if (present(no_overwrite)) then  !{
2664   call fm_util_set_no_overwrite(no_overwrite)
2665 else  !}{
2666   call fm_util_reset_no_overwrite
2667 endif  !}
2668
2669 !
2670 !       set the default good_name_list string, if desired
2671 !
2672
2673 if (present(check)) then  !{
2674   if (check) then  !{
2675     call fm_util_set_good_name_list('/ocean_mod/GOOD/namelists/' // trim(path_name) // '/good_list')
2676   else  !}{
2677     call fm_util_reset_good_name_list
2678   endif  !}
2679 else  !}{
2680   call fm_util_reset_good_name_list
2681 endif  !}
2682
2683 !
2684 !       Process the namelist
2685 !
2686
2687 write (out_unit,*)
2688 write (out_unit,*) trim(note_header), ' Processing namelist ', trim(path_name)
2689
2690 !
2691 !       Check whether the namelist already exists. If so, then use that one
2692 !
2693
2694 namelist_index = fm_get_index('/ocean_mod/namelists/' // trim(path_name))
2695 if (namelist_index .gt. 0) then  !{
2696
2697   !write (out_unit,*) trim(note_header), ' Namelist already set with index ', namelist_index
2698
2699 else  !}{
2700
2701 !
2702 !       Set a new namelist and get its index
2703 !
2704
2705   namelist_index = fm_new_list('/ocean_mod/namelists/' // trim(path_name), create = .true.)
2706   if (namelist_index .le. 0) then  !{
2707     call mpp_error(FATAL, trim(error_header) // ' Could not set namelist ' // trim(path_name))
2708   endif  !}
2709
2710 endif  !}
2711
2712 !
2713 !       Add the namelist name to the list of good namelists, to be used
2714 !       later for a consistency check
2715 !
2716
2717 if (fm_new_value('/ocean_mod/GOOD/namelists/' // trim(path) // '/good_values',    &
2718                  name, append = .true., create = .true.) .le. 0) then  !{
2719   call mpp_error(FATAL, trim(error_header) //                           &
2720        ' Could not add ' // trim(name) // ' to "' // trim(path) // '/good_values" list')
2721 endif  !}
2722
2723 !
2724 !       Change to the new namelist, first saving the current list
2725 !
2726
2727 save_current_list = fm_get_current_list()
2728 if (save_current_list .eq. ' ') then  !{
2729   call mpp_error(FATAL, trim(error_header) // ' Could not get the current list')
2730 endif  !}
2731
2732 if (.not. fm_change_list('/ocean_mod/namelists/' // trim(path_name))) then  !{
2733   call mpp_error(FATAL, trim(error_header) // ' Could not change to the namelist ' // trim(path_name))
2734 endif  !}
2735
2736 return
2737
2738 end subroutine fm_util_start_namelist  !}
2739
2740 !#######################################################################
2741
2742 !> Finish up processing a namelist
2743 subroutine fm_util_end_namelist(path, name, caller, check)  !{
2744
2745 implicit none
2746
2747 !
2748 !       arguments
2749 !
2750
2751 character(len=*), intent(in)            :: path
2752 character(len=*), intent(in)            :: name
2753 character(len=*), intent(in), optional  :: caller
2754 logical,          intent(in), optional  :: check
2755
2756 !
2757 !       Local parameters
2758 !
2759
2760 character(len=48), parameter  :: sub_name = 'fm_util_end_namelist'
2761
2762 !
2763 !       Local variables
2764 !
2765
2766 character(len=fm_string_len), pointer, dimension(:)     :: good_list => NULL()
2767 character(len=FMS_PATH_LEN)                             :: path_name
2768 character(len=256)                                      :: error_header
2769 character(len=256)                                      :: warn_header
2770 character(len=256)                                      :: note_header
2771 character(len=128)                                      :: caller_str
2772
2773 !
2774 !       set the caller string and headers
2775 !
2776
2777 if (present(caller)) then  !{
2778   caller_str = '[' // trim(caller) // ']'
2779 else  !}{
2780   caller_str = fm_util_default_caller
2781 endif  !}
2782
2783 error_header = '==>Error from ' // trim(mod_name) //   &
2784                '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2785 warn_header = '==>Warning from ' // trim(mod_name) //  &
2786               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2787 note_header = '==>Note from ' // trim(mod_name) //     &
2788               '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
2789
2790 !
2791 !       check that a path is given (fatal if not)
2792 !
2793
2794 if (name .eq. ' ') then  !{
2795   call mpp_error(FATAL, trim(error_header) // ' Empty name given')
2796 endif  !}
2797
2798 !
2799 !       Check that the path ane name match the preceding call to
2800 !       fm_util_start_namelist
2801 !
2802
2803 if (path .ne. save_path) then  !{
2804   call mpp_error(FATAL, trim(error_header) // &
2805                  &  ' Path "' // trim(path) // '" does not match saved path "' // trim(save_path) // '"')
2806 elseif (name .ne. save_name) then  !}{
2807   call mpp_error(FATAL, trim(error_header) // &
2808                  &  ' Name "' // trim(name) // '" does not match saved name "' // trim(save_name) // '"')
2809 endif  !}
2810
2811 !
2812 !       Concatenate the path and name
2813 !
2814
2815 if (path .eq. ' ') then  !{
2816   path_name = name
2817 else  !}{
2818   path_name = trim(path) // '/' // name
2819 endif  !}
2820 save_path = ' '
2821 save_name = ' '
2822
2823 !
2824 !       Check for any errors in the number of fields in this list
2825 !
2826
2827 if (present(check)) then  !{
2828   if (check) then  !{
2829     if (caller_str .eq. ' ') then  !{
2830       caller_str = trim(mod_name) // '(' // trim(sub_name) // ')'
2831     endif  !}
2832     good_list => fm_util_get_string_array('/ocean_mod/GOOD/namelists/' // trim(path_name) // '/good_list',            &
2833          caller = trim(mod_name) // '(' // trim(sub_name) // ')')
2834     if (associated(good_list)) then  !{
2835       call fm_util_check_for_bad_fields('/ocean_mod/namelists/' // trim(path_name), good_list, caller = caller_str)
2836       deallocate(good_list)
2837     else  !}{
2838       call mpp_error(FATAL, trim(error_header) // ' Empty "' // trim(path_name) // '" list')
2839     endif  !}
2840   endif  !}
2841 endif  !}
2842
2843 !
2844 !       Change back to the saved list
2845 !
2846
2847 if (save_current_list .ne. ' ') then  !{
2848   if (.not. fm_change_list(save_current_list)) then  !{
2849     call mpp_error(FATAL, trim(error_header) // ' Could not change to the saved list: ' // trim(save_current_list))
2850   endif  !}
2851 endif  !}
2852 save_current_list = ' '
2853
2854 !
2855 !       reset the default caller string
2856 !
2857
2858 call fm_util_reset_caller
2859
2860 !
2861 !       reset the default no_overwrite string
2862 !
2863
2864 call fm_util_reset_no_overwrite
2865
2866 !
2867 !       reset the default good_name_list string
2868 !
2869
2870 call fm_util_reset_good_name_list
2871
2872 return
2873
2874 end subroutine fm_util_end_namelist  !}
2875
2876 #include "fm_util_r4.fh"
2877 #include "fm_util_r8.fh"
2878
2879 end module fm_util_mod  !}
2880 !> @}
2881 ! close documentation grouping