36use fms_mod,
only: fatal, stdout
38use platform_mod,
only: r4_kind, r8_kind, fms_path_len
71character(len=128),
public :: fm_util_default_caller =
' '
77character(len=48),
parameter :: mod_name =
'fm_util_mod'
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
92#include<file_version.h>
101 module procedure fm_util_set_value_real_r4
102 module procedure fm_util_set_value_real_r8
106 module procedure fm_util_set_value_real_array_r4
107 module procedure fm_util_set_value_real_array_r8
113 module procedure fm_util_set_value_real_array_r4
114 module procedure fm_util_set_value_real_array_r8
117 module procedure fm_util_set_value_real_r4
118 module procedure fm_util_set_value_real_r8
145character(len=*),
intent(in) :: caller
155save_default_caller = fm_util_default_caller
161if (caller .eq.
' ')
then
162 fm_util_default_caller =
' '
164 fm_util_default_caller =
'[' // trim(caller) //
']'
191fm_util_default_caller = save_default_caller
192save_default_caller =
' '
210character(len=*),
intent(in) :: good_name_list
220save_default_good_name_list = default_good_name_list
226default_good_name_list = good_name_list
252default_good_name_list = save_default_good_name_list
253save_default_good_name_list =
' '
271logical,
intent(in) :: no_overwrite
281save_default_no_overwrite = default_no_overwrite
287default_no_overwrite = no_overwrite
313default_no_overwrite = save_default_no_overwrite
314save_default_no_overwrite = .false.
331character(len=*),
intent(in) :: list
332character(len=*),
intent(in),
dimension(:) :: good_fields
333character(len=*),
intent(in),
optional :: caller
339character(len=48),
parameter :: sub_name =
'fm_util_check_for_bad_fields'
348integer :: list_length
349integer :: good_length
350character(len=fm_type_name_len) :: typ
351character(len=fm_field_name_len) :: name
353character(len=256) :: error_header
354character(len=256) :: warn_header
355character(len=256) :: note_header
356character(len=128) :: caller_str
365if (
present(caller))
then
366 caller_str =
'[' // trim(caller) //
']'
368 caller_str = fm_util_default_caller
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) //
':'
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')
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))
401if (list_length .lt. 0)
then
402 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(list))
409good_length =
size(good_fields)
411if (list_length .lt. good_length)
then
419 write (out_unit,*) trim(error_header),
' List length < number of good fields (', &
420 list_length,
' < ', good_length,
') in list ', trim(list)
423 write (out_unit,*)
'The list contains the following fields:'
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)),
'"'
431 write (out_unit,*)
'EXTRA good field: "', trim(good_fields(i)),
'"'
436 call mpp_error(fatal, trim(error_header) // &
437 ' List length < number of good fields for list: ' // trim(list))
439elseif (list_length .gt. good_length)
then
447 write (out_unit,*) trim(warn_header),
'List length > number of good fields (', &
448 list_length,
' > ', good_length,
') in list ', trim(list)
450 write (out_unit,*) trim(error_header),
' Start of list of fields'
453 do i = 1, good_length
454 found = found .or. (name .eq. good_fields(i))
457 write (out_unit,*)
'Good list field: "', trim(name),
'"'
459 write (out_unit,*)
'EXTRA list field: "', trim(name),
'"'
462 write (out_unit,*) trim(error_header),
' End of list of fields'
464 call mpp_error(fatal, trim(error_header) // &
465 ' List length > number of good fields for list: ' // trim(list))
489integer :: field_length
495character(len=*),
intent(in) :: name
496character(len=*),
intent(in),
optional :: caller
502character(len=48),
parameter :: sub_name =
'fm_util_get_length'
508character(len=256) :: error_header
509character(len=256) :: warn_header
510character(len=256) :: note_header
511character(len=128) :: caller_str
517if (
present(caller))
then
518 caller_str =
'[' // trim(caller) //
']'
520 caller_str = fm_util_default_caller
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) //
':'
534if (name .eq.
' ')
then
535 call mpp_error(fatal, trim(error_header) //
' Empty name given')
543if (field_length .lt. 0)
then
544 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
569character(len=*),
intent(in) :: name
570character(len=*),
intent(in) :: string
571character(len=*),
intent(in),
optional :: caller
577character(len=48),
parameter :: sub_name =
'fm_util_get_index_string'
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
597if (
present(caller))
then
598 caller_str =
'[' // trim(caller) //
']'
600 caller_str = fm_util_default_caller
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) //
':'
614if (name .eq.
' ')
then
615 call mpp_error(fatal, trim(error_header) //
' Empty name given')
624if (fm_type .eq.
'string')
then
626 if (length .lt. 0)
then
627 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
629 if (length .gt. 0)
then
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))
635 if (fm_string .eq. string)
then
641elseif (fm_type .eq.
' ')
then
642 call mpp_error(fatal, trim(error_header) //
' Array does not exist: ' // trim(name))
644 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
673character(len=*),
intent(in) :: name
674character(len=*),
intent(in),
optional :: caller
680character(len=48),
parameter :: sub_name =
'fm_util_get_index_list'
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
696if (
present(caller))
then
697 caller_str =
'[' // trim(caller) //
']'
699 caller_str = fm_util_default_caller
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) //
':'
713if (name .eq.
' ')
then
714 call mpp_error(fatal, trim(error_header) //
' Empty name given')
723if (fm_type .eq.
'list')
then
725 if (fm_index .le. 0)
then
726 call mpp_error(fatal, trim(error_header) //
' List does not exist: ' // trim(name))
728elseif (fm_type .eq.
' ')
then
729 call mpp_error(fatal, trim(error_header) //
' List does not exist: ' // trim(name))
731 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
752integer,
pointer,
dimension(:) :: array
758character(len=*),
intent(in) :: name
759character(len=*),
intent(in),
optional :: caller
765character(len=48),
parameter :: sub_name =
'fm_util_get_integer_array'
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
786if (
present(caller))
then
787 caller_str =
'[' // trim(caller) //
']'
789 caller_str = fm_util_default_caller
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) //
':'
803if (name .eq.
' ')
then
804 call mpp_error(fatal, trim(error_header) //
' Empty name given')
808if (fm_type .eq.
'integer')
then
810 if (length .lt. 0)
then
811 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
813 if (length .gt. 0)
then
814 allocate(array(length))
817 write (index_str,*)
'(', i,
')'
818 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name) // trim(index_str))
822elseif (fm_type .eq.
' ')
then
823 call mpp_error(fatal, trim(error_header) //
' Array does not exist: ' // trim(name))
825 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
844logical,
pointer,
dimension(:) :: array
850character(len=*),
intent(in) :: name
851character(len=*),
intent(in),
optional :: caller
857character(len=48),
parameter :: sub_name =
'fm_util_get_logical_array'
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
878if (
present(caller))
then
879 caller_str =
'[' // trim(caller) //
']'
881 caller_str = fm_util_default_caller
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) //
':'
895if (name .eq.
' ')
then
896 call mpp_error(fatal, trim(error_header) //
' Empty name given')
900if (fm_type .eq.
'logical')
then
902 if (length .lt. 0)
then
903 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
905 if (length .gt. 0)
then
906 allocate(array(length))
909 write (index_str,*)
'(', i,
')'
910 call mpp_error(fatal, trim(error_header) //
' Problem getting ' // trim(name) // trim(index_str))
914elseif (fm_type .eq.
' ')
then
915 call mpp_error(fatal, trim(error_header) //
' Array does not exist: ' // trim(name))
917 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
936real(r8_kind),
pointer,
dimension(:) :: array
942character(len=*),
intent(in) :: name
943character(len=*),
intent(in),
optional :: caller
949character(len=48),
parameter :: sub_name =
'fm_util_get_real_array'
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
970if (
present(caller))
then
971 caller_str =
'[' // trim(caller) //
']'
973 caller_str = fm_util_default_caller
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) //
':'
987if (name .eq.
' ')
then
988 call mpp_error(fatal, trim(error_header) //
' Empty name given')
992if (fm_type .eq.
'real')
then
994 if (length .lt. 0)
then
995 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
997 if (length .gt. 0)
then
998 allocate(array(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))
1006elseif (fm_type .eq.
' ')
then
1007 call mpp_error(fatal, trim(error_header) //
' Array does not exist: ' // trim(name))
1009 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
1029character(len=fm_string_len),
pointer,
dimension(:) :: array
1035character(len=*),
intent(in) :: name
1036character(len=*),
intent(in),
optional :: caller
1042character(len=48),
parameter :: sub_name =
'fm_util_get_string_array'
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
1063if (
present(caller))
then
1064 caller_str =
'[' // trim(caller) //
']'
1066 caller_str = fm_util_default_caller
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) //
':'
1080if (name .eq.
' ')
then
1081 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1085if (fm_type .eq.
'string')
then
1087 if (length .lt. 0)
then
1088 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1090 if (length .gt. 0)
then
1091 allocate(array(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))
1099elseif (fm_type .eq.
' ')
then
1100 call mpp_error(fatal, trim(error_header) //
' Array does not exist: ' // trim(name))
1102 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
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
1137character(len=48),
parameter :: sub_name =
'fm_util_get_integer'
1143character(len=256) :: error_header
1144character(len=256) :: warn_header
1145character(len=256) :: note_header
1146character(len=128) :: caller_str
1148character(len=fm_type_name_len) :: fm_type
1149integer :: field_length
1155if (
present(caller))
then
1156 caller_str =
'[' // trim(caller) //
']'
1158 caller_str = fm_util_default_caller
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) //
':'
1172if (name .eq.
' ')
then
1173 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1181if (
present(scalar))
then
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')
1196if (
present(index))
then
1198 if (index .le. 0)
then
1199 call mpp_error(fatal, trim(error_header) //
' Index not positive')
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))
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))
1215 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
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
1250character(len=48),
parameter :: sub_name =
'fm_util_get_logical'
1256character(len=256) :: error_header
1257character(len=256) :: warn_header
1258character(len=256) :: note_header
1259character(len=128) :: caller_str
1261character(len=fm_type_name_len) :: fm_type
1262integer :: field_length
1268if (
present(caller))
then
1269 caller_str =
'[' // trim(caller) //
']'
1271 caller_str = fm_util_default_caller
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) //
':'
1285if (name .eq.
' ')
then
1286 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1294if (
present(scalar))
then
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')
1309if (
present(index))
then
1311 if (index .le. 0)
then
1312 call mpp_error(fatal, trim(error_header) //
' Index not positive')
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))
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))
1328 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
1348real(r8_kind) :: rval
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
1364character(len=48),
parameter :: sub_name =
'fm_util_get_real'
1370character(len=256) :: error_header
1371character(len=256) :: warn_header
1372character(len=256) :: note_header
1373character(len=128) :: caller_str
1375character(len=fm_type_name_len) :: fm_type
1376integer :: field_length
1383if (
present(caller))
then
1384 caller_str =
'[' // trim(caller) //
']'
1386 caller_str = fm_util_default_caller
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) //
':'
1400if (name .eq.
' ')
then
1401 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1409if (
present(scalar))
then
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')
1424if (
present(index))
then
1426 if (index .le. 0)
then
1427 call mpp_error(fatal, trim(error_header) //
' Index not positive')
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))
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))
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))
1448 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
1469character(len=fm_string_len) :: sval
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
1485character(len=48),
parameter :: sub_name =
'fm_util_get_string'
1491character(len=256) :: error_header
1492character(len=256) :: warn_header
1493character(len=256) :: note_header
1494character(len=128) :: caller_str
1496character(len=fm_type_name_len) :: fm_type
1497integer :: field_length
1503if (
present(caller))
then
1504 caller_str =
'[' // trim(caller) //
']'
1506 caller_str = fm_util_default_caller
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) //
':'
1520if (name .eq.
' ')
then
1521 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1529if (
present(scalar))
then
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')
1544if (
present(index))
then
1546 if (index .le. 0)
then
1547 call mpp_error(fatal, trim(error_header) //
' Index not positive')
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))
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))
1563 call mpp_error(fatal, trim(error_header) //
' Wrong type for ' // trim(name) //
', found (' // trim(fm_type) //
')')
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
1592character(len=48),
parameter :: sub_name =
'fm_util_set_value_integer_array'
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
1606logical :: no_overwrite_use
1607character(len=FMS_PATH_LEN) :: good_name_list_use
1614if (
present(caller))
then
1615 caller_str =
'[' // trim(caller) //
']'
1617 caller_str = fm_util_default_caller
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) //
':'
1631if (name .eq.
' ')
then
1632 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1639if (length .lt. 0)
then
1640 call mpp_error(fatal, trim(error_header) //
' Negative array length')
1647if (
present(no_overwrite))
then
1648 no_overwrite_use = no_overwrite
1650 no_overwrite_use = default_no_overwrite
1657if (
present(good_name_list))
then
1658 good_name_list_use = good_name_list
1660 good_name_list_use = default_good_name_list
1667if (length .eq. 0)
then
1668 if (.not. (no_overwrite_use .and.
fm_exists(name)))
then
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))
1676 if (no_overwrite_use .and.
fm_exists(name))
then
1678 if (field_length .lt. 0)
then
1679 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1681 do n = field_length + 1, length
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))
1690 if (field_index .le. 0)
then
1691 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name))
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))
1708if (good_name_list_use .ne.
' ')
then
1711 caller = caller_str) .le. 0
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')
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
1749character(len=48),
parameter :: sub_name =
'fm_util_set_value_logical_array'
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
1763logical :: no_overwrite_use
1764character(len=FMS_PATH_LEN) :: good_name_list_use
1771if (
present(caller))
then
1772 caller_str =
'[' // trim(caller) //
']'
1774 caller_str = fm_util_default_caller
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) //
':'
1788if (name .eq.
' ')
then
1789 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1796if (length .lt. 0)
then
1797 call mpp_error(fatal, trim(error_header) //
' Negative array length')
1804if (
present(no_overwrite))
then
1805 no_overwrite_use = no_overwrite
1807 no_overwrite_use = default_no_overwrite
1814if (
present(good_name_list))
then
1815 good_name_list_use = good_name_list
1817 good_name_list_use = default_good_name_list
1824if (length .eq. 0)
then
1825 if (.not. (no_overwrite_use .and.
fm_exists(name)))
then
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))
1833 if (no_overwrite_use .and.
fm_exists(name))
then
1835 if (field_length .lt. 0)
then
1836 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1838 do n = field_length + 1, length
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))
1847 if (field_index .le. 0)
then
1848 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name))
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))
1865if (good_name_list_use .ne.
' ')
then
1868 caller = caller_str) .le. 0
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')
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
1906character(len=48),
parameter :: sub_name =
'fm_util_set_value_string_array'
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
1920logical :: no_overwrite_use
1921character(len=FMS_PATH_LEN) :: good_name_list_use
1928if (
present(caller))
then
1929 caller_str =
'[' // trim(caller) //
']'
1931 caller_str = fm_util_default_caller
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) //
':'
1945if (name .eq.
' ')
then
1946 call mpp_error(fatal, trim(error_header) //
' Empty name given')
1953if (length .lt. 0)
then
1954 call mpp_error(fatal, trim(error_header) //
' Negative array length')
1961if (
present(no_overwrite))
then
1962 no_overwrite_use = no_overwrite
1964 no_overwrite_use = default_no_overwrite
1971if (
present(good_name_list))
then
1972 good_name_list_use = good_name_list
1974 good_name_list_use = default_good_name_list
1981if (length .eq. 0)
then
1982 if (.not. (no_overwrite_use .and.
fm_exists(name)))
then
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))
1990 if (no_overwrite_use .and.
fm_exists(name))
then
1992 if (field_length .lt. 0)
then
1993 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
1995 do n = field_length + 1, length
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))
2004 if (field_index .le. 0)
then
2005 call mpp_error(fatal, trim(error_header) //
' Problem setting ' // trim(name))
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))
2022if (good_name_list_use .ne.
' ')
then
2025 caller = caller_str) .le. 0
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')
2045 no_overwrite, good_name_list)
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
2066character(len=48),
parameter :: sub_name =
'fm_util_set_value_integer'
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
2088if (
present(caller))
then
2089 caller_str =
'[' // trim(caller) //
']'
2091 caller_str = fm_util_default_caller
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) //
':'
2105if (name .eq.
' ')
then
2106 call mpp_error(fatal, trim(error_header) //
' Empty name given')
2113if (
present(index) .and.
present(append))
then
2114 call mpp_error(fatal, trim(error_header) //
' Append and index both given as arguments')
2121if (
present(no_overwrite))
then
2122 no_overwrite_use = no_overwrite
2124 no_overwrite_use = default_no_overwrite
2131if (
present(good_name_list))
then
2132 good_name_list_use = good_name_list
2134 good_name_list_use = default_good_name_list
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))
2147if (
present(index))
then
2150 if (field_length .lt. 0)
then
2151 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
2153 if (.not. (no_overwrite_use .and. field_length .ge. index))
then
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))
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))
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))
2175 if (.not. no_overwrite_use)
then
2177 if (field_index .le. 0)
then
2178 call mpp_error(fatal, trim(error_header) //
' Problem overwriting ' // trim(name))
2181 elseif (create)
then
2183 if (field_index .le. 0)
then
2184 call mpp_error(fatal, trim(error_header) //
' Problem creating ' // trim(name))
2194if (good_name_list_use .ne.
' ')
then
2197 caller = caller_str) .le. 0
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')
2217 no_overwrite, good_name_list)
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
2238character(len=48),
parameter :: sub_name =
'fm_util_set_value_logical'
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
2260if (
present(caller))
then
2261 caller_str =
'[' // trim(caller) //
']'
2263 caller_str = fm_util_default_caller
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) //
':'
2277if (name .eq.
' ')
then
2278 call mpp_error(fatal, trim(error_header) //
' Empty name given')
2285if (
present(index) .and.
present(append))
then
2286 call mpp_error(fatal, trim(error_header) //
' Append and index both given as arguments')
2293if (
present(no_overwrite))
then
2294 no_overwrite_use = no_overwrite
2296 no_overwrite_use = default_no_overwrite
2303if (
present(good_name_list))
then
2304 good_name_list_use = good_name_list
2306 good_name_list_use = default_good_name_list
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))
2319if (
present(index))
then
2322 if (field_length .lt. 0)
then
2323 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
2325 if (.not. (no_overwrite_use .and. field_length .ge. index))
then
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))
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))
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))
2347 if (.not. no_overwrite_use)
then
2349 if (field_index .le. 0)
then
2350 call mpp_error(fatal, trim(error_header) //
' Problem overwriting ' // trim(name))
2353 elseif (create)
then
2355 if (field_index .le. 0)
then
2356 call mpp_error(fatal, trim(error_header) //
' Problem creating ' // trim(name))
2366if (good_name_list_use .ne.
' ')
then
2369 caller = caller_str) .le. 0
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')
2388 no_overwrite, good_name_list)
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
2409character(len=48),
parameter :: sub_name =
'fm_util_set_value_string'
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
2431if (
present(caller))
then
2432 caller_str =
'[' // trim(caller) //
']'
2434 caller_str = fm_util_default_caller
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) //
':'
2448if (name .eq.
' ')
then
2449 call mpp_error(fatal, trim(error_header) //
' Empty name given')
2456if (
present(index) .and.
present(append))
then
2457 call mpp_error(fatal, trim(error_header) //
' Append and index both given as arguments')
2464if (
present(no_overwrite))
then
2465 no_overwrite_use = no_overwrite
2467 no_overwrite_use = default_no_overwrite
2474if (
present(good_name_list))
then
2475 good_name_list_use = good_name_list
2477 good_name_list_use = default_good_name_list
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))
2490if (
present(index))
then
2493 if (field_length .lt. 0)
then
2494 call mpp_error(fatal, trim(error_header) //
' Problem getting length of ' // trim(name))
2496 if (.not. (no_overwrite_use .and. field_length .ge. index))
then
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))
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))
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))
2518 if (.not. no_overwrite_use)
then
2520 if (field_index .le. 0)
then
2521 call mpp_error(fatal, trim(error_header) //
' Problem overwriting ' // trim(name))
2524 elseif (create)
then
2526 if (field_index .le. 0)
then
2527 call mpp_error(fatal, trim(error_header) //
' Problem creating ' // trim(name))
2537if (good_name_list_use .ne.
' ')
then
2540 caller = caller_str) .le. 0
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')
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
2577character(len=48),
parameter :: sub_name =
'fm_util_start_namelist'
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
2597if (
present(caller))
then
2598 caller_str =
'[' // trim(caller) //
']'
2600 caller_str = fm_util_default_caller
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) //
':'
2614if (name .eq.
' ')
then
2615 call mpp_error(fatal, trim(error_header) //
' Empty name given')
2622if (path .eq.
' ')
then
2625 path_name = trim(path) //
'/' // name
2634if (
present(caller))
then
2644if (
present(no_overwrite))
then
2654if (
present(check))
then
2669write (out_unit,*) trim(note_header),
' Processing namelist ', trim(path_name)
2675namelist_index =
fm_get_index(
'/ocean_mod/namelists/' // trim(path_name))
2676if (namelist_index .gt. 0)
then
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))
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')
2709if (save_current_list .eq.
' ')
then
2710 call mpp_error(fatal, trim(error_header) //
' Could not get the current list')
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))
2732character(len=*),
intent(in) :: path
2733character(len=*),
intent(in) :: name
2734character(len=*),
intent(in),
optional :: caller
2735logical,
intent(in),
optional :: check
2741character(len=48),
parameter :: sub_name =
'fm_util_end_namelist'
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
2758if (
present(caller))
then
2759 caller_str =
'[' // trim(caller) //
']'
2761 caller_str = fm_util_default_caller
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) //
':'
2775if (name .eq.
' ')
then
2776 call mpp_error(fatal, trim(error_header) //
' Empty name given')
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) //
'"')
2796if (path .eq.
' ')
then
2799 path_name = trim(path) //
'/' // name
2808if (
present(check))
then
2810 if (caller_str .eq.
' ')
then
2811 caller_str = trim(mod_name) //
'(' // trim(sub_name) //
')'
2814 caller = trim(mod_name) //
'(' // trim(sub_name) //
')')
2815 if (
associated(good_list))
then
2817 deallocate(good_list)
2819 call mpp_error(fatal, trim(error_header) //
' Empty "' // trim(path_name) //
'" list')
2828if (save_current_list .ne.
' ')
then
2830 call mpp_error(fatal, trim(error_header) //
' Could not change to the saved list: ' // trim(save_current_list))
2833save_current_list =
' '
2857#include "fm_util_r4.fh"
2858#include "fm_util_r8.fh"
2860end module fm_util_mod
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.
integer function, public fm_util_get_length(name, caller)
Get the length of an element of 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.
integer function, public fm_util_get_index_list(name, caller)
Get the length of an element of the Field Manager tree.
real(r8_kind) function, dimension(:), pointer, public fm_util_get_real_array(name, caller)
Get a real value from 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.
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 ...
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.
subroutine, public fm_util_start_namelist(path, name, caller, no_overwrite, check)
Start processing a namelist.
subroutine, public fm_util_check_for_bad_fields(list, good_fields, caller)
Check for unrecognized fields in a list.
logical function, dimension(:), pointer, public fm_util_get_logical_array(name, caller)
Get a logical 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.
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_end_namelist(path, name, caller, check)
Finish up processing a namelist.
real(r8_kind) function, public fm_util_get_real(name, caller, index, default_value, scalar)
Get a real value from 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.
integer function, public fm_util_get_integer(name, caller, index, default_value, scalar)
Get an integer value from the Field Manager tree.
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.
logical function, public fm_util_get_logical(name, caller, index, default_value, scalar)
Get a logical value from the Field Manager tree.
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 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, public fm_util_reset_no_overwrite
Reset the default value for the optional "no_overwrite" variable used in some of these subroutines to...
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, public fm_util_set_no_overwrite(no_overwrite)
Set the default value for the optional "no_overwrite" variable used in some 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.