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