35 use fms_mod,
only: fatal,
stdout
37 use platform_mod,
only: r4_kind, r8_kind, fms_path_len
70 character(len=128),
public :: fm_util_default_caller =
' '
76 character(len=48),
parameter :: mod_name =
'fm_util_mod'
82 character(len=128) :: save_default_caller =
' '
83 character(len=128) :: default_good_name_list =
' '
84 character(len=128) :: save_default_good_name_list =
' '
85 logical :: default_no_overwrite = .false.
86 logical :: save_default_no_overwrite = .false.
87 character(len=FMS_PATH_LEN) :: save_current_list
88 character(len=FMS_PATH_LEN) :: save_path
89 character(len=FMS_PATH_LEN) :: save_name
91 #include<file_version.h>
100 module procedure fm_util_set_value_real_r4
101 module procedure fm_util_set_value_real_r8
105 module procedure fm_util_set_value_real_array_r4
106 module procedure fm_util_set_value_real_array_r8
112 module procedure fm_util_set_value_real_array_r4
113 module procedure fm_util_set_value_real_array_r8
116 module procedure fm_util_set_value_real_r4
117 module procedure fm_util_set_value_real_r8
144 character(len=*),
intent(in) :: caller
154 save_default_caller = fm_util_default_caller
160 if (caller .eq.
' ')
then
161 fm_util_default_caller =
' '
163 fm_util_default_caller =
'[' // trim(caller) //
']'
190 fm_util_default_caller = save_default_caller
191 save_default_caller =
' '
209 character(len=*),
intent(in) :: good_name_list
219 save_default_good_name_list = default_good_name_list
225 default_good_name_list = good_name_list
251 default_good_name_list = save_default_good_name_list
252 save_default_good_name_list =
' '
270 logical,
intent(in) :: no_overwrite
280 save_default_no_overwrite = default_no_overwrite
286 default_no_overwrite = no_overwrite
312 default_no_overwrite = save_default_no_overwrite
313 save_default_no_overwrite = .false.
330 character(len=*),
intent(in) :: list
331 character(len=*),
intent(in),
dimension(:) :: good_fields
332 character(len=*),
intent(in),
optional :: caller
338 character(len=48),
parameter :: sub_name =
'fm_util_check_for_bad_fields'
344 logical :: fm_success
347 integer :: list_length
348 integer :: good_length
349 character(len=fm_type_name_len) :: typ
350 character(len=fm_field_name_len) :: name
352 character(len=256) :: error_header
353 character(len=256) :: warn_header
354 character(len=256) :: note_header
355 character(len=128) :: caller_str
364 if (
present(caller))
then
365 caller_str =
'[' // trim(caller) //
']'
367 caller_str = fm_util_default_caller
370 error_header =
'==>Error from ' // trim(mod_name) // &
371 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
372 warn_header =
'==>Warning from ' // trim(mod_name) // &
373 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
374 note_header =
'==>Note from ' // trim(mod_name) // &
375 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
381 if (list .eq.
' ')
then
382 write (out_unit,*) trim(error_header) //
' Empty list given'
383 call mpp_error(fatal, trim(error_header) //
' Empty list given')
390 if (fm_get_type(list) .ne.
'list')
then
391 write (out_unit,*) trim(error_header) //
' Not given a list: ' // trim(list)
392 call mpp_error(fatal, trim(error_header) //
' Not given a list: ' // trim(list))
399 list_length = fm_get_length(list)
400 if (list_length .lt. 0)
then
401 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(list))
408 good_length =
size(good_fields)
410 if (list_length .lt. good_length)
then
418 write (out_unit,*) trim(error_header),
' List length < number of good fields (', &
419 list_length,
' < ', good_length,
') in list ', trim(list)
422 write (out_unit,*)
'The list contains the following fields:'
425 write (out_unit,*)
'The supposed list of good fields is:'
426 do i = 1, good_length
427 if (
fm_exists(trim(list) //
'/' // good_fields(i)))
then
428 write (out_unit,*)
'List field: "', trim(good_fields(i)),
'"'
430 write (out_unit,*)
'EXTRA good field: "', trim(good_fields(i)),
'"'
435 call mpp_error(fatal, trim(error_header) // &
436 ' List length < number of good fields for list: ' // trim(list))
438 elseif (list_length .gt. good_length)
then
446 write (out_unit,*) trim(warn_header),
'List length > number of good fields (', &
447 list_length,
' > ', good_length,
') in list ', trim(list)
449 write (out_unit,*) trim(error_header),
' Start of list of fields'
452 do i = 1, good_length
453 found = found .or. (name .eq. good_fields(i))
456 write (out_unit,*)
'Good list field: "', trim(name),
'"'
458 write (out_unit,*)
'EXTRA list field: "', trim(name),
'"'
461 write (out_unit,*) trim(error_header),
' End of list of fields'
463 call mpp_error(fatal, trim(error_header) // &
464 ' List length > number of good fields for list: ' // trim(list))
488 integer :: field_length
494 character(len=*),
intent(in) :: name
495 character(len=*),
intent(in),
optional :: caller
501 character(len=48),
parameter :: sub_name =
'fm_util_get_length'
507 character(len=256) :: error_header
508 character(len=256) :: warn_header
509 character(len=256) :: note_header
510 character(len=128) :: caller_str
516 if (
present(caller))
then
517 caller_str =
'[' // trim(caller) //
']'
519 caller_str = fm_util_default_caller
522 error_header =
'==>Error from ' // trim(mod_name) // &
523 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
524 warn_header =
'==>Warning from ' // trim(mod_name) // &
525 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
526 note_header =
'==>Note from ' // trim(mod_name) // &
527 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
533 if (name .eq.
' ')
then
534 call mpp_error(fatal, trim(error_header) //
' Empty name given')
541 field_length = fm_get_length(name)
542 if (field_length .lt. 0)
then
543 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
568 character(len=*),
intent(in) :: name
569 character(len=*),
intent(in) :: string
570 character(len=*),
intent(in),
optional :: caller
576 character(len=48),
parameter :: sub_name =
'fm_util_get_index_string'
582 character(len=256) :: error_header
583 character(len=256) :: warn_header
584 character(len=256) :: note_header
585 character(len=128) :: caller_str
586 character(len=32) :: index_str
587 character(len=fm_type_name_len) :: fm_type
588 character(len=fm_string_len) :: fm_string
596 if (
present(caller))
then
597 caller_str =
'[' // trim(caller) //
']'
599 caller_str = fm_util_default_caller
602 error_header =
'==>Error from ' // trim(mod_name) // &
603 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
604 warn_header =
'==>Warning from ' // trim(mod_name) // &
605 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
606 note_header =
'==>Note from ' // trim(mod_name) // &
607 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
613 if (name .eq.
' ')
then
614 call mpp_error(fatal, trim(error_header) //
' Empty name given')
622 fm_type = fm_get_type(name)
623 if (fm_type .eq.
'string')
then
624 length = fm_get_length(name)
625 if (length .lt. 0)
then
626 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
628 if (length .gt. 0)
then
630 if (.not.
fm_get_value(name, fm_string, index = i))
then
631 write (index_str,*)
'(', i,
')'
632 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name) // trim(index_str))
634 if (fm_string .eq. string)
then
640 elseif (fm_type .eq.
' ')
then
641 call mpp_error(fatal, trim(error_header) //
' Array does not exist: ' // trim(name))
643 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
672 character(len=*),
intent(in) :: name
673 character(len=*),
intent(in),
optional :: caller
679 character(len=48),
parameter :: sub_name =
'fm_util_get_index_list'
685 character(len=256) :: error_header
686 character(len=256) :: warn_header
687 character(len=256) :: note_header
688 character(len=128) :: caller_str
689 character(len=fm_type_name_len) :: fm_type
695 if (
present(caller))
then
696 caller_str =
'[' // trim(caller) //
']'
698 caller_str = fm_util_default_caller
701 error_header =
'==>Error from ' // trim(mod_name) // &
702 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
703 warn_header =
'==>Warning from ' // trim(mod_name) // &
704 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
705 note_header =
'==>Note from ' // trim(mod_name) // &
706 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
712 if (name .eq.
' ')
then
713 call mpp_error(fatal, trim(error_header) //
' Empty name given')
721 fm_type = fm_get_type(name)
722 if (fm_type .eq.
'list')
then
723 fm_index = fm_get_index(name)
724 if (fm_index .le. 0)
then
725 call mpp_error(fatal, trim(error_header) //
' List does not exist: ' // trim(name))
727 elseif (fm_type .eq.
' ')
then
728 call mpp_error(fatal, trim(error_header) //
' List does not exist: ' // trim(name))
730 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
751 integer,
pointer,
dimension(:) :: array
757 character(len=*),
intent(in) :: name
758 character(len=*),
intent(in),
optional :: caller
764 character(len=48),
parameter :: sub_name =
'fm_util_get_integer_array'
770 character(len=256) :: error_header
771 character(len=256) :: warn_header
772 character(len=256) :: note_header
773 character(len=128) :: caller_str
774 character(len=32) :: index_str
775 character(len=fm_type_name_len) :: fm_type
785 if (
present(caller))
then
786 caller_str =
'[' // trim(caller) //
']'
788 caller_str = fm_util_default_caller
791 error_header =
'==>Error from ' // trim(mod_name) // &
792 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
793 warn_header =
'==>Warning from ' // trim(mod_name) // &
794 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
795 note_header =
'==>Note from ' // trim(mod_name) // &
796 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
802 if (name .eq.
' ')
then
803 call mpp_error(fatal, trim(error_header) //
' Empty name given')
806 fm_type = fm_get_type(name)
807 if (fm_type .eq.
'integer')
then
808 length = fm_get_length(name)
809 if (length .lt. 0)
then
810 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
812 if (length .gt. 0)
then
813 allocate(array(length))
816 write (index_str,*)
'(', i,
')'
817 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name) // trim(index_str))
821 elseif (fm_type .eq.
' ')
then
822 call mpp_error(fatal, trim(error_header) //
' Array does not exist: ' // trim(name))
824 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
843 logical,
pointer,
dimension(:) :: array
849 character(len=*),
intent(in) :: name
850 character(len=*),
intent(in),
optional :: caller
856 character(len=48),
parameter :: sub_name =
'fm_util_get_logical_array'
862 character(len=256) :: error_header
863 character(len=256) :: warn_header
864 character(len=256) :: note_header
865 character(len=128) :: caller_str
866 character(len=32) :: index_str
867 character(len=fm_type_name_len) :: fm_type
877 if (
present(caller))
then
878 caller_str =
'[' // trim(caller) //
']'
880 caller_str = fm_util_default_caller
883 error_header =
'==>Error from ' // trim(mod_name) // &
884 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
885 warn_header =
'==>Warning from ' // trim(mod_name) // &
886 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
887 note_header =
'==>Note from ' // trim(mod_name) // &
888 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
894 if (name .eq.
' ')
then
895 call mpp_error(fatal, trim(error_header) //
' Empty name given')
898 fm_type = fm_get_type(name)
899 if (fm_type .eq.
'logical')
then
900 length = fm_get_length(name)
901 if (length .lt. 0)
then
902 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
904 if (length .gt. 0)
then
905 allocate(array(length))
908 write (index_str,*)
'(', i,
')'
909 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name) // trim(index_str))
913 elseif (fm_type .eq.
' ')
then
914 call mpp_error(fatal, trim(error_header) //
' Array does not exist: ' // trim(name))
916 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
935 real(r8_kind),
pointer,
dimension(:) :: array
941 character(len=*),
intent(in) :: name
942 character(len=*),
intent(in),
optional :: caller
948 character(len=48),
parameter :: sub_name =
'fm_util_get_real_array'
954 character(len=256) :: error_header
955 character(len=256) :: warn_header
956 character(len=256) :: note_header
957 character(len=128) :: caller_str
958 character(len=32) :: index_str
959 character(len=fm_type_name_len) :: fm_type
969 if (
present(caller))
then
970 caller_str =
'[' // trim(caller) //
']'
972 caller_str = fm_util_default_caller
975 error_header =
'==>Error from ' // trim(mod_name) // &
976 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
977 warn_header =
'==>Warning from ' // trim(mod_name) // &
978 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
979 note_header =
'==>Note from ' // trim(mod_name) // &
980 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
986 if (name .eq.
' ')
then
987 call mpp_error(fatal, trim(error_header) //
' Empty name given')
990 fm_type = fm_get_type(name)
991 if (fm_type .eq.
'real')
then
992 length = fm_get_length(name)
993 if (length .lt. 0)
then
994 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
996 if (length .gt. 0)
then
997 allocate(array(length))
1000 write (index_str,*)
'(', i,
')'
1001 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name) // trim(index_str))
1005 elseif (fm_type .eq.
' ')
then
1006 call mpp_error(fatal, trim(error_header) //
' Array does not exist: ' // trim(name))
1008 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
1028 character(len=fm_string_len),
pointer,
dimension(:) :: array
1034 character(len=*),
intent(in) :: name
1035 character(len=*),
intent(in),
optional :: caller
1041 character(len=48),
parameter :: sub_name =
'fm_util_get_string_array'
1047 character(len=256) :: error_header
1048 character(len=256) :: warn_header
1049 character(len=256) :: note_header
1050 character(len=128) :: caller_str
1051 character(len=32) :: index_str
1052 character(len=fm_type_name_len) :: fm_type
1062 if (
present(caller))
then
1063 caller_str =
'[' // trim(caller) //
']'
1065 caller_str = fm_util_default_caller
1068 error_header =
'==>Error from ' // trim(mod_name) // &
1069 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1070 warn_header =
'==>Warning from ' // trim(mod_name) // &
1071 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1072 note_header =
'==>Note from ' // trim(mod_name) // &
1073 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1079 if (name .eq.
' ')
then
1080 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1083 fm_type = fm_get_type(name)
1084 if (fm_type .eq.
'string')
then
1085 length = fm_get_length(name)
1086 if (length .lt. 0)
then
1087 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1089 if (length .gt. 0)
then
1090 allocate(array(length))
1092 if (.not.
fm_get_value(name, array(i), index = i))
then
1093 write (index_str,*)
'(', i,
')'
1094 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name) // trim(index_str))
1098 elseif (fm_type .eq.
' ')
then
1099 call mpp_error(fatal, trim(error_header) //
' Array does not exist: ' // trim(name))
1101 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
1126 character(len=*),
intent(in) :: name
1127 character(len=*),
intent(in),
optional :: caller
1128 integer,
intent(in),
optional :: index
1129 integer,
intent(in),
optional :: default_value
1130 logical,
intent(in),
optional :: scalar
1136 character(len=48),
parameter :: sub_name =
'fm_util_get_integer'
1142 character(len=256) :: error_header
1143 character(len=256) :: warn_header
1144 character(len=256) :: note_header
1145 character(len=128) :: caller_str
1147 character(len=fm_type_name_len) :: fm_type
1148 integer :: field_length
1154 if (
present(caller))
then
1155 caller_str =
'[' // trim(caller) //
']'
1157 caller_str = fm_util_default_caller
1160 error_header =
'==>Error from ' // trim(mod_name) // &
1161 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1162 warn_header =
'==>Warning from ' // trim(mod_name) // &
1163 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1164 note_header =
'==>Note from ' // trim(mod_name) // &
1165 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1171 if (name .eq.
' ')
then
1172 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1180 if (
present(scalar))
then
1182 field_length = fm_get_length(name)
1183 if (field_length .lt. 0)
then
1184 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1185 elseif (field_length .gt. 1)
then
1186 call mpp_error(fatal, trim(error_header) // trim(name) //
' not scalar')
1195 if (
present(index))
then
1197 if (index .le. 0)
then
1198 call mpp_error(fatal, trim(error_header) //
' Index not positive')
1204 fm_type = fm_get_type(name)
1205 if (fm_type .eq.
'integer')
then
1206 if (.not.
fm_get_value(name, ival, index = index_t))
then
1207 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name))
1209 elseif (fm_type .eq.
' ' .and.
present(default_value))
then
1210 ival = default_value
1211 elseif (fm_type .eq.
' ')
then
1212 call mpp_error(fatal, trim(error_header) //
' Field does not exist: ' // trim(name))
1214 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
1239 character(len=*),
intent(in) :: name
1240 character(len=*),
intent(in),
optional :: caller
1241 integer,
intent(in),
optional :: index
1242 logical,
intent(in),
optional :: default_value
1243 logical,
intent(in),
optional :: scalar
1249 character(len=48),
parameter :: sub_name =
'fm_util_get_logical'
1255 character(len=256) :: error_header
1256 character(len=256) :: warn_header
1257 character(len=256) :: note_header
1258 character(len=128) :: caller_str
1260 character(len=fm_type_name_len) :: fm_type
1261 integer :: field_length
1267 if (
present(caller))
then
1268 caller_str =
'[' // trim(caller) //
']'
1270 caller_str = fm_util_default_caller
1273 error_header =
'==>Error from ' // trim(mod_name) // &
1274 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1275 warn_header =
'==>Warning from ' // trim(mod_name) // &
1276 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1277 note_header =
'==>Note from ' // trim(mod_name) // &
1278 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1284 if (name .eq.
' ')
then
1285 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1293 if (
present(scalar))
then
1295 field_length = fm_get_length(name)
1296 if (field_length .lt. 0)
then
1297 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1298 elseif (field_length .gt. 1)
then
1299 call mpp_error(fatal, trim(error_header) // trim(name) //
' not scalar')
1308 if (
present(index))
then
1310 if (index .le. 0)
then
1311 call mpp_error(fatal, trim(error_header) //
' Index not positive')
1317 fm_type = fm_get_type(name)
1318 if (fm_type .eq.
'logical')
then
1319 if (.not.
fm_get_value(name, lval, index = index_t))
then
1320 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name))
1322 elseif (fm_type .eq.
' ' .and.
present(default_value))
then
1323 lval = default_value
1324 elseif (fm_type .eq.
' ')
then
1325 call mpp_error(fatal, trim(error_header) //
' Field does not exist: ' // trim(name))
1327 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
1347 real(r8_kind) :: rval
1353 character(len=*),
intent(in) :: name
1354 character(len=*),
intent(in),
optional :: caller
1355 integer,
intent(in),
optional :: index
1356 real(r8_kind),
intent(in),
optional :: default_value
1357 logical,
intent(in),
optional :: scalar
1363 character(len=48),
parameter :: sub_name =
'fm_util_get_real'
1369 character(len=256) :: error_header
1370 character(len=256) :: warn_header
1371 character(len=256) :: note_header
1372 character(len=128) :: caller_str
1374 character(len=fm_type_name_len) :: fm_type
1375 integer :: field_length
1382 if (
present(caller))
then
1383 caller_str =
'[' // trim(caller) //
']'
1385 caller_str = fm_util_default_caller
1388 error_header =
'==>Error from ' // trim(mod_name) // &
1389 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1390 warn_header =
'==>Warning from ' // trim(mod_name) // &
1391 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1392 note_header =
'==>Note from ' // trim(mod_name) // &
1393 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1399 if (name .eq.
' ')
then
1400 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1408 if (
present(scalar))
then
1410 field_length = fm_get_length(name)
1411 if (field_length .lt. 0)
then
1412 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1413 elseif (field_length .gt. 1)
then
1414 call mpp_error(fatal, trim(error_header) // trim(name) //
' not scalar')
1423 if (
present(index))
then
1425 if (index .le. 0)
then
1426 call mpp_error(fatal, trim(error_header) //
' Index not positive')
1432 fm_type = fm_get_type(name)
1433 if (fm_type .eq.
'real')
then
1434 if (.not.
fm_get_value(name, rval, index = index_t))
then
1435 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name))
1437 else if (fm_type .eq.
'integer')
then
1438 if (.not.
fm_get_value(name, ivalue, index = index_t))
then
1439 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name))
1441 rval = real(ivalue,r8_kind)
1442 elseif (fm_type .eq.
' ' .and.
present(default_value))
then
1443 rval = default_value
1444 elseif (fm_type .eq.
' ')
then
1445 call mpp_error(fatal, trim(error_header) //
' Field does not exist: ' // trim(name))
1447 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
1468 character(len=fm_string_len) :: sval
1474 character(len=*),
intent(in) :: name
1475 character(len=*),
intent(in),
optional :: caller
1476 integer,
intent(in),
optional :: index
1477 character(len=*),
intent(in),
optional :: default_value
1478 logical,
intent(in),
optional :: scalar
1484 character(len=48),
parameter :: sub_name =
'fm_util_get_string'
1490 character(len=256) :: error_header
1491 character(len=256) :: warn_header
1492 character(len=256) :: note_header
1493 character(len=128) :: caller_str
1495 character(len=fm_type_name_len) :: fm_type
1496 integer :: field_length
1502 if (
present(caller))
then
1503 caller_str =
'[' // trim(caller) //
']'
1505 caller_str = fm_util_default_caller
1508 error_header =
'==>Error from ' // trim(mod_name) // &
1509 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1510 warn_header =
'==>Warning from ' // trim(mod_name) // &
1511 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1512 note_header =
'==>Note from ' // trim(mod_name) // &
1513 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1519 if (name .eq.
' ')
then
1520 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1528 if (
present(scalar))
then
1530 field_length = fm_get_length(name)
1531 if (field_length .lt. 0)
then
1532 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1533 elseif (field_length .gt. 1)
then
1534 call mpp_error(fatal, trim(error_header) // trim(name) //
' not scalar')
1543 if (
present(index))
then
1545 if (index .le. 0)
then
1546 call mpp_error(fatal, trim(error_header) //
' Index not positive')
1552 fm_type = fm_get_type(name)
1553 if (fm_type .eq.
'string')
then
1554 if (.not.
fm_get_value(name, sval, index = index_t))
then
1555 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name))
1557 elseif (fm_type .eq.
' ' .and.
present(default_value))
then
1558 sval = default_value
1559 elseif (fm_type .eq.
' ')
then
1560 call mpp_error(fatal, trim(error_header) //
' Field does not exist: ' // trim(name))
1562 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
1580 character(len=*),
intent(in) :: name
1581 integer,
intent(in) :: length
1582 integer,
intent(in) :: ival(length)
1583 character(len=*),
intent(in),
optional :: caller
1584 logical,
intent(in),
optional :: no_overwrite
1585 character(len=*),
intent(in),
optional :: good_name_list
1591 character(len=48),
parameter :: sub_name =
'fm_util_set_value_integer_array'
1597 character(len=256) :: error_header
1598 character(len=256) :: warn_header
1599 character(len=256) :: note_header
1600 character(len=128) :: caller_str
1601 character(len=32) :: str_error
1602 integer :: field_index
1603 integer :: field_length
1605 logical :: no_overwrite_use
1606 character(len=FMS_PATH_LEN) :: good_name_list_use
1613 if (
present(caller))
then
1614 caller_str =
'[' // trim(caller) //
']'
1616 caller_str = fm_util_default_caller
1619 error_header =
'==>Error from ' // trim(mod_name) // &
1620 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1621 warn_header =
'==>Warning from ' // trim(mod_name) // &
1622 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1623 note_header =
'==>Note from ' // trim(mod_name) // &
1624 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1630 if (name .eq.
' ')
then
1631 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1638 if (length .lt. 0)
then
1639 call mpp_error(fatal, trim(error_header) //
' Negative array length')
1646 if (
present(no_overwrite))
then
1647 no_overwrite_use = no_overwrite
1649 no_overwrite_use = default_no_overwrite
1656 if (
present(good_name_list))
then
1657 good_name_list_use = good_name_list
1659 good_name_list_use = default_good_name_list
1666 if (length .eq. 0)
then
1667 if (.not. (no_overwrite_use .and.
fm_exists(name)))
then
1669 if (field_index .le. 0)
then
1670 write (str_error,*)
' with length = ', length
1671 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
1675 if (no_overwrite_use .and.
fm_exists(name))
then
1676 field_length = fm_get_length(name)
1677 if (field_length .lt. 0)
then
1678 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1680 do n = field_length + 1, length
1682 if (field_index .le. 0)
then
1683 write (str_error,*)
' with index = ', n
1684 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
1689 if (field_index .le. 0)
then
1690 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name))
1694 if (field_index .le. 0)
then
1695 write (str_error,*)
' with index = ', n
1696 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
1707 if (good_name_list_use .ne.
' ')
then
1710 caller = caller_str) .le. 0
1714 if (add_name .and.
fm_exists(name))
then
1715 if (
fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0)
then
1716 call mpp_error(fatal, trim(error_header) // &
1717 ' Could not add ' // trim(name) //
' to "' // trim(good_name_list_use) //
'" list')
1737 character(len=*),
intent(in) :: name
1738 integer,
intent(in) :: length
1739 logical,
intent(in) :: lval(length)
1740 character(len=*),
intent(in),
optional :: caller
1741 logical,
intent(in),
optional :: no_overwrite
1742 character(len=*),
intent(in),
optional :: good_name_list
1748 character(len=48),
parameter :: sub_name =
'fm_util_set_value_logical_array'
1754 character(len=256) :: error_header
1755 character(len=256) :: warn_header
1756 character(len=256) :: note_header
1757 character(len=128) :: caller_str
1758 character(len=32) :: str_error
1759 integer :: field_index
1760 integer :: field_length
1762 logical :: no_overwrite_use
1763 character(len=FMS_PATH_LEN) :: good_name_list_use
1770 if (
present(caller))
then
1771 caller_str =
'[' // trim(caller) //
']'
1773 caller_str = fm_util_default_caller
1776 error_header =
'==>Error from ' // trim(mod_name) // &
1777 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1778 warn_header =
'==>Warning from ' // trim(mod_name) // &
1779 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1780 note_header =
'==>Note from ' // trim(mod_name) // &
1781 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1787 if (name .eq.
' ')
then
1788 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1795 if (length .lt. 0)
then
1796 call mpp_error(fatal, trim(error_header) //
' Negative array length')
1803 if (
present(no_overwrite))
then
1804 no_overwrite_use = no_overwrite
1806 no_overwrite_use = default_no_overwrite
1813 if (
present(good_name_list))
then
1814 good_name_list_use = good_name_list
1816 good_name_list_use = default_good_name_list
1823 if (length .eq. 0)
then
1824 if (.not. (no_overwrite_use .and.
fm_exists(name)))
then
1826 if (field_index .le. 0)
then
1827 write (str_error,*)
' with length = ', length
1828 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
1832 if (no_overwrite_use .and.
fm_exists(name))
then
1833 field_length = fm_get_length(name)
1834 if (field_length .lt. 0)
then
1835 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1837 do n = field_length + 1, length
1839 if (field_index .le. 0)
then
1840 write (str_error,*)
' with index = ', n
1841 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
1846 if (field_index .le. 0)
then
1847 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name))
1851 if (field_index .le. 0)
then
1852 write (str_error,*)
' with index = ', n
1853 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
1864 if (good_name_list_use .ne.
' ')
then
1867 caller = caller_str) .le. 0
1871 if (add_name .and.
fm_exists(name))
then
1872 if (
fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0)
then
1873 call mpp_error(fatal, trim(error_header) // &
1874 ' Could not add ' // trim(name) //
' to "' // trim(good_name_list_use) //
'" list')
1894 character(len=*),
intent(in) :: name
1895 integer,
intent(in) :: length
1896 character(len=*),
intent(in) :: sval(length)
1897 character(len=*),
intent(in),
optional :: caller
1898 logical,
intent(in),
optional :: no_overwrite
1899 character(len=*),
intent(in),
optional :: good_name_list
1905 character(len=48),
parameter :: sub_name =
'fm_util_set_value_string_array'
1911 character(len=256) :: error_header
1912 character(len=256) :: warn_header
1913 character(len=256) :: note_header
1914 character(len=128) :: caller_str
1915 character(len=32) :: str_error
1916 integer :: field_index
1917 integer :: field_length
1919 logical :: no_overwrite_use
1920 character(len=FMS_PATH_LEN) :: good_name_list_use
1927 if (
present(caller))
then
1928 caller_str =
'[' // trim(caller) //
']'
1930 caller_str = fm_util_default_caller
1933 error_header =
'==>Error from ' // trim(mod_name) // &
1934 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1935 warn_header =
'==>Warning from ' // trim(mod_name) // &
1936 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1937 note_header =
'==>Note from ' // trim(mod_name) // &
1938 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
1944 if (name .eq.
' ')
then
1945 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1952 if (length .lt. 0)
then
1953 call mpp_error(fatal, trim(error_header) //
' Negative array length')
1960 if (
present(no_overwrite))
then
1961 no_overwrite_use = no_overwrite
1963 no_overwrite_use = default_no_overwrite
1970 if (
present(good_name_list))
then
1971 good_name_list_use = good_name_list
1973 good_name_list_use = default_good_name_list
1980 if (length .eq. 0)
then
1981 if (.not. (no_overwrite_use .and.
fm_exists(name)))
then
1983 if (field_index .le. 0)
then
1984 write (str_error,*)
' with length = ', length
1985 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
1989 if (no_overwrite_use .and.
fm_exists(name))
then
1990 field_length = fm_get_length(name)
1991 if (field_length .lt. 0)
then
1992 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1994 do n = field_length + 1, length
1996 if (field_index .le. 0)
then
1997 write (str_error,*)
' with index = ', n
1998 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
2003 if (field_index .le. 0)
then
2004 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name))
2008 if (field_index .le. 0)
then
2009 write (str_error,*)
' with index = ', n
2010 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
2021 if (good_name_list_use .ne.
' ')
then
2024 caller = caller_str) .le. 0
2028 if (add_name .and.
fm_exists(name))
then
2029 if (
fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0)
then
2030 call mpp_error(fatal, trim(error_header) // &
2031 ' Could not add ' // trim(name) //
' to "' // trim(good_name_list_use) //
'" list')
2044 no_overwrite, good_name_list)
2052 character(len=*),
intent(in) :: name
2053 integer,
intent(in) :: ival
2054 character(len=*),
intent(in),
optional :: caller
2055 integer,
intent(in),
optional :: index
2056 logical,
intent(in),
optional :: append
2057 logical,
intent(in),
optional :: no_create
2058 logical,
intent(in),
optional :: no_overwrite
2059 character(len=*),
intent(in),
optional :: good_name_list
2065 character(len=48),
parameter :: sub_name =
'fm_util_set_value_integer'
2071 character(len=256) :: error_header
2072 character(len=256) :: warn_header
2073 character(len=256) :: note_header
2074 character(len=128) :: caller_str
2075 character(len=32) :: str_error
2076 integer :: field_index
2077 logical :: no_overwrite_use
2078 integer :: field_length
2079 character(len=FMS_PATH_LEN) :: good_name_list_use
2087 if (
present(caller))
then
2088 caller_str =
'[' // trim(caller) //
']'
2090 caller_str = fm_util_default_caller
2093 error_header =
'==>Error from ' // trim(mod_name) // &
2094 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2095 warn_header =
'==>Warning from ' // trim(mod_name) // &
2096 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2097 note_header =
'==>Note from ' // trim(mod_name) // &
2098 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2104 if (name .eq.
' ')
then
2105 call mpp_error(fatal, trim(error_header) //
' Empty name given')
2112 if (
present(index) .and.
present(append))
then
2113 call mpp_error(fatal, trim(error_header) //
' Append and index both given as arguments')
2120 if (
present(no_overwrite))
then
2121 no_overwrite_use = no_overwrite
2123 no_overwrite_use = default_no_overwrite
2130 if (
present(good_name_list))
then
2131 good_name_list_use = good_name_list
2133 good_name_list_use = default_good_name_list
2136 if (
present(no_create))
then
2137 create = .not. no_create
2138 if (no_create .and. (
present(append) .or.
present(index)))
then
2139 call mpp_error(fatal, trim(error_header) // &
2140 &
' append or index are present when no_create is true for ' // trim(name))
2146 if (
present(index))
then
2148 field_length = fm_get_length(name)
2149 if (field_length .lt. 0)
then
2150 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
2152 if (.not. (no_overwrite_use .and. field_length .ge. index))
then
2154 if (field_index .le. 0)
then
2155 write (str_error,*)
' with index = ', index
2156 call mpp_error(fatal, trim(error_header) //
' Problem overwriting ' // trim(name) // trim(str_error))
2161 if (field_index .le. 0)
then
2162 write (str_error,*)
' with index = ', index
2163 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
2166 elseif (
present(append))
then
2167 field_index =
fm_new_value(name, ival, append = append)
2168 if (field_index .le. 0)
then
2169 write (str_error,*)
' with append = ', append
2170 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
2174 if (.not. no_overwrite_use)
then
2176 if (field_index .le. 0)
then
2177 call mpp_error(fatal, trim(error_header) //
' Problem overwriting ' // trim(name))
2180 elseif (create)
then
2182 if (field_index .le. 0)
then
2183 call mpp_error(fatal, trim(error_header) //
' Problem creating ' // trim(name))
2193 if (good_name_list_use .ne.
' ')
then
2196 caller = caller_str) .le. 0
2200 if (add_name .and.
fm_exists(name))
then
2201 if (
fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0)
then
2202 call mpp_error(fatal, trim(error_header) // &
2203 ' Could not add ' // trim(name) //
' to "' // trim(good_name_list_use) //
'" list')
2216 no_overwrite, good_name_list)
2224 character(len=*),
intent(in) :: name
2225 logical,
intent(in) :: lval
2226 character(len=*),
intent(in),
optional :: caller
2227 integer,
intent(in),
optional :: index
2228 logical,
intent(in),
optional :: append
2229 logical,
intent(in),
optional :: no_create
2230 logical,
intent(in),
optional :: no_overwrite
2231 character(len=*),
intent(in),
optional :: good_name_list
2237 character(len=48),
parameter :: sub_name =
'fm_util_set_value_logical'
2243 character(len=256) :: error_header
2244 character(len=256) :: warn_header
2245 character(len=256) :: note_header
2246 character(len=128) :: caller_str
2247 character(len=32) :: str_error
2248 integer :: field_index
2249 logical :: no_overwrite_use
2250 integer :: field_length
2251 character(len=FMS_PATH_LEN) :: good_name_list_use
2259 if (
present(caller))
then
2260 caller_str =
'[' // trim(caller) //
']'
2262 caller_str = fm_util_default_caller
2265 error_header =
'==>Error from ' // trim(mod_name) // &
2266 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2267 warn_header =
'==>Warning from ' // trim(mod_name) // &
2268 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2269 note_header =
'==>Note from ' // trim(mod_name) // &
2270 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2276 if (name .eq.
' ')
then
2277 call mpp_error(fatal, trim(error_header) //
' Empty name given')
2284 if (
present(index) .and.
present(append))
then
2285 call mpp_error(fatal, trim(error_header) //
' Append and index both given as arguments')
2292 if (
present(no_overwrite))
then
2293 no_overwrite_use = no_overwrite
2295 no_overwrite_use = default_no_overwrite
2302 if (
present(good_name_list))
then
2303 good_name_list_use = good_name_list
2305 good_name_list_use = default_good_name_list
2308 if (
present(no_create))
then
2309 create = .not. no_create
2310 if (no_create .and. (
present(append) .or.
present(index)))
then
2311 call mpp_error(fatal, trim(error_header) // &
2312 &
' append or index are present when no_create is true for ' // trim(name))
2318 if (
present(index))
then
2320 field_length = fm_get_length(name)
2321 if (field_length .lt. 0)
then
2322 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
2324 if (.not. (no_overwrite_use .and. field_length .ge. index))
then
2326 if (field_index .le. 0)
then
2327 write (str_error,*)
' with index = ', index
2328 call mpp_error(fatal, trim(error_header) //
' Problem overwriting ' // trim(name) // trim(str_error))
2333 if (field_index .le. 0)
then
2334 write (str_error,*)
' with index = ', index
2335 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
2338 elseif (
present(append))
then
2339 field_index =
fm_new_value(name, lval, append = append)
2340 if (field_index .le. 0)
then
2341 write (str_error,*)
' with append = ', append
2342 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
2346 if (.not. no_overwrite_use)
then
2348 if (field_index .le. 0)
then
2349 call mpp_error(fatal, trim(error_header) //
' Problem overwriting ' // trim(name))
2352 elseif (create)
then
2354 if (field_index .le. 0)
then
2355 call mpp_error(fatal, trim(error_header) //
' Problem creating ' // trim(name))
2365 if (good_name_list_use .ne.
' ')
then
2368 caller = caller_str) .le. 0
2372 if (add_name .and.
fm_exists(name))
then
2373 if (
fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0)
then
2374 call mpp_error(fatal, trim(error_header) // &
2375 ' Could not add ' // trim(name) //
' to "' // trim(good_name_list_use) //
'" list')
2387 no_overwrite, good_name_list)
2395 character(len=*),
intent(in) :: name
2396 character(len=*),
intent(in) :: sval
2397 character(len=*),
intent(in),
optional :: caller
2398 integer,
intent(in),
optional :: index
2399 logical,
intent(in),
optional :: append
2400 logical,
intent(in),
optional :: no_create
2401 logical,
intent(in),
optional :: no_overwrite
2402 character(len=*),
intent(in),
optional :: good_name_list
2408 character(len=48),
parameter :: sub_name =
'fm_util_set_value_string'
2414 character(len=256) :: error_header
2415 character(len=256) :: warn_header
2416 character(len=256) :: note_header
2417 character(len=128) :: caller_str
2418 character(len=32) :: str_error
2419 integer :: field_index
2420 logical :: no_overwrite_use
2421 integer :: field_length
2422 character(len=FMS_PATH_LEN) :: good_name_list_use
2430 if (
present(caller))
then
2431 caller_str =
'[' // trim(caller) //
']'
2433 caller_str = fm_util_default_caller
2436 error_header =
'==>Error from ' // trim(mod_name) // &
2437 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2438 warn_header =
'==>Warning from ' // trim(mod_name) // &
2439 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2440 note_header =
'==>Note from ' // trim(mod_name) // &
2441 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2447 if (name .eq.
' ')
then
2448 call mpp_error(fatal, trim(error_header) //
' Empty name given')
2455 if (
present(index) .and.
present(append))
then
2456 call mpp_error(fatal, trim(error_header) //
' Append and index both given as arguments')
2463 if (
present(no_overwrite))
then
2464 no_overwrite_use = no_overwrite
2466 no_overwrite_use = default_no_overwrite
2473 if (
present(good_name_list))
then
2474 good_name_list_use = good_name_list
2476 good_name_list_use = default_good_name_list
2479 if (
present(no_create))
then
2480 create = .not. no_create
2481 if (no_create .and. (
present(append) .or.
present(index)))
then
2482 call mpp_error(fatal, trim(error_header) // &
2483 &
' append or index are present when no_create is true for ' // trim(name))
2489 if (
present(index))
then
2491 field_length = fm_get_length(name)
2492 if (field_length .lt. 0)
then
2493 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
2495 if (.not. (no_overwrite_use .and. field_length .ge. index))
then
2497 if (field_index .le. 0)
then
2498 write (str_error,*)
' with index = ', index
2499 call mpp_error(fatal, trim(error_header) //
' Problem overwriting ' // trim(name) // trim(str_error))
2504 if (field_index .le. 0)
then
2505 write (str_error,*)
' with index = ', index
2506 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
2509 elseif (
present(append))
then
2510 field_index =
fm_new_value(name, sval, append = append)
2511 if (field_index .le. 0)
then
2512 write (str_error,*)
' with append = ', append
2513 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name) // trim(str_error))
2517 if (.not. no_overwrite_use)
then
2519 if (field_index .le. 0)
then
2520 call mpp_error(fatal, trim(error_header) //
' Problem overwriting ' // trim(name))
2523 elseif (create)
then
2525 if (field_index .le. 0)
then
2526 call mpp_error(fatal, trim(error_header) //
' Problem creating ' // trim(name))
2536 if (good_name_list_use .ne.
' ')
then
2539 caller = caller_str) .le. 0
2543 if (add_name .and.
fm_exists(name))
then
2544 if (
fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0)
then
2545 call mpp_error(fatal, trim(error_header) // &
2546 ' Could not add ' // trim(name) //
' to "' // trim(good_name_list_use) //
'" list')
2566 character(len=*),
intent(in) :: path
2567 character(len=*),
intent(in) :: name
2568 character(len=*),
intent(in),
optional :: caller
2569 logical,
intent(in),
optional :: no_overwrite
2570 logical,
intent(in),
optional :: check
2576 character(len=48),
parameter :: sub_name =
'fm_util_start_namelist'
2582 integer :: namelist_index
2583 character(len=FMS_PATH_LEN) :: path_name
2584 character(len=256) :: error_header
2585 character(len=256) :: warn_header
2586 character(len=256) :: note_header
2587 character(len=128) :: caller_str
2596 if (
present(caller))
then
2597 caller_str =
'[' // trim(caller) //
']'
2599 caller_str = fm_util_default_caller
2602 error_header =
'==>Error from ' // trim(mod_name) // &
2603 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2604 warn_header =
'==>Warning from ' // trim(mod_name) // &
2605 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2606 note_header =
'==>Note from ' // trim(mod_name) // &
2607 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2613 if (name .eq.
' ')
then
2614 call mpp_error(fatal, trim(error_header) //
' Empty name given')
2621 if (path .eq.
' ')
then
2624 path_name = trim(path) //
'/' // name
2633 if (
present(caller))
then
2643 if (
present(no_overwrite))
then
2653 if (
present(check))
then
2668 write (out_unit,*) trim(note_header),
' Processing namelist ', trim(path_name)
2674 namelist_index = fm_get_index(
'/ocean_mod/namelists/' // trim(path_name))
2675 if (namelist_index .gt. 0)
then
2685 namelist_index = fm_new_list(
'/ocean_mod/namelists/' // trim(path_name), create = .true.)
2686 if (namelist_index .le. 0)
then
2687 call mpp_error(fatal, trim(error_header) //
' Could not set namelist ' // trim(path_name))
2697 if (
fm_new_value(
'/ocean_mod/GOOD/namelists/' // trim(path) //
'/good_values', &
2698 name, append = .true., create = .true.) .le. 0)
then
2699 call mpp_error(fatal, trim(error_header) // &
2700 ' Could not add ' // trim(name) //
' to "' // trim(path) //
'/good_values" list')
2707 save_current_list = fm_get_current_list()
2708 if (save_current_list .eq.
' ')
then
2709 call mpp_error(fatal, trim(error_header) //
' Could not get the current list')
2712 if (.not. fm_change_list(
'/ocean_mod/namelists/' // trim(path_name)))
then
2713 call mpp_error(fatal, trim(error_header) //
' Could not change to the namelist ' // trim(path_name))
2731 character(len=*),
intent(in) :: path
2732 character(len=*),
intent(in) :: name
2733 character(len=*),
intent(in),
optional :: caller
2734 logical,
intent(in),
optional :: check
2740 character(len=48),
parameter :: sub_name =
'fm_util_end_namelist'
2746 character(len=fm_string_len),
pointer,
dimension(:) :: good_list => null()
2747 character(len=FMS_PATH_LEN) :: path_name
2748 character(len=256) :: error_header
2749 character(len=256) :: warn_header
2750 character(len=256) :: note_header
2751 character(len=128) :: caller_str
2757 if (
present(caller))
then
2758 caller_str =
'[' // trim(caller) //
']'
2760 caller_str = fm_util_default_caller
2763 error_header =
'==>Error from ' // trim(mod_name) // &
2764 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2765 warn_header =
'==>Warning from ' // trim(mod_name) // &
2766 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2767 note_header =
'==>Note from ' // trim(mod_name) // &
2768 '(' // trim(sub_name) //
')' // trim(caller_str) //
':'
2774 if (name .eq.
' ')
then
2775 call mpp_error(fatal, trim(error_header) //
' Empty name given')
2783 if (path .ne. save_path)
then
2784 call mpp_error(fatal, trim(error_header) // &
2785 &
' Path "' // trim(path) //
'" does not match saved path "' // trim(save_path) //
'"')
2786 elseif (name .ne. save_name)
then
2787 call mpp_error(fatal, trim(error_header) // &
2788 &
' Name "' // trim(name) //
'" does not match saved name "' // trim(save_name) //
'"')
2795 if (path .eq.
' ')
then
2798 path_name = trim(path) //
'/' // name
2807 if (
present(check))
then
2809 if (caller_str .eq.
' ')
then
2810 caller_str = trim(mod_name) //
'(' // trim(sub_name) //
')'
2813 caller = trim(mod_name) //
'(' // trim(sub_name) //
')')
2814 if (
associated(good_list))
then
2816 deallocate(good_list)
2818 call mpp_error(fatal, trim(error_header) //
' Empty "' // trim(path_name) //
'" list')
2827 if (save_current_list .ne.
' ')
then
2828 if (.not. fm_change_list(save_current_list))
then
2829 call mpp_error(fatal, trim(error_header) //
' Could not change to the saved list: ' // trim(save_current_list))
2832 save_current_list =
' '
2856 #include "fm_util_r4.fh"
2857 #include "fm_util_r8.fh"
2859 end module fm_util_mod
integer, parameter, public fm_string_len
The length of a character string representing character values for the field.
integer function, public fm_get_length(name)
A function to return how many elements are contained within the named list or entry.
character(len=8) function, public fm_get_type(name)
A function to return the type of the named field.
logical function, public fm_exists(name)
A function to test whether a named field exists.
logical function, public fm_change_list(name)
Change the current list. Return true on success, false otherwise.
integer function, public fm_new_list(name, create, keep)
A function to create a new list.
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.
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...
logical function, public fm_dump_list(name, recursive, unit)
A function to list properties associated with a field.
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.
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.
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.
subroutine, public fm_util_reset_no_overwrite
Reset the default value for the optional "no_overwrite" variable used in some of these subroutines to...
subroutine, public fm_util_start_namelist(path, name, caller, no_overwrite, check)
Start processing a namelist.
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.
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.
logical function, dimension(:), pointer, public fm_util_get_logical_array(name, caller)
Get a logical value from the Field Manager tree.
subroutine, public fm_util_end_namelist(path, name, caller, check)
Finish up processing a namelist.
subroutine, public fm_util_check_for_bad_fields(list, good_fields, caller)
Check for unrecognized fields in a list.
integer function, public fm_util_get_index_list(name, caller)
Get the length of an element of the Field Manager tree.
integer function, public fm_util_get_length(name, caller)
Get the length of an element of the Field Manager tree.
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.
logical function, public fm_util_get_logical(name, caller, index, default_value, scalar)
Get a logical value from the Field Manager tree.
subroutine, public fm_util_set_caller(caller)
Set the default value for the optional "caller" variable used in many of these subroutines....
subroutine, public fm_util_reset_caller
Reset the default value for the optional "caller" variable used in many of these subroutines to blank...
integer function, dimension(:), pointer, public fm_util_get_integer_array(name, caller)
Get an integer value from the Field Manager tree.
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 ...
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.
real(r8_kind) function, public fm_util_get_real(name, caller, index, default_value, scalar)
Get a real value from the Field Manager tree.
integer function, public fm_util_get_integer(name, caller, index, default_value, scalar)
Get an integer value from the Field Manager tree.
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.
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.
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.
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.
real(r8_kind) function, dimension(:), pointer, public fm_util_get_real_array(name, caller)
Get a real value from the Field Manager tree.
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.
integer function stdout()
This function returns the current standard fortran unit numbers for output.