156 module field_manager_mod
159 #define MAXFIELDS_ 250
163 #ifndef MAXFIELDMETHODS_
164 #define MAXFIELDMETHODS_ 250
189 use fms_mod,
only : lowercase, &
192 use fms2_io_mod,
only: file_exists, get_instance_filename
193 use platform_mod,
only: r4_kind, r8_kind, fms_path_len, fms_file_len
201 #include<file_version.h>
202 logical :: module_is_initialized = .false.
267 character(len=11),
parameter,
public,
dimension(NUM_MODELS) :: &
268 model_names=(/
'atmospheric',
'oceanic ',
'land ',
'ice ',
'coupler '/)
288 character(len=fm_string_len) :: method_name
291 character(len=fm_string_len) :: method_control
302 character(len=fm_string_len) :: method_type
303 character(len=fm_string_len) :: method_name
312 character(len=fm_string_len) :: method_type
353 module procedure parse_real_r4
354 module procedure parse_real_r8
355 module procedure parse_reals_r4
356 module procedure parse_reals_r8
382 module procedure fm_new_value_real_r4
383 module procedure fm_new_value_real_r8
401 module procedure fm_get_value_real_r4
402 module procedure fm_get_value_real_r8
420 character(len=17),
parameter :: module_name =
'field_manager_mod'
421 character(len=33),
parameter :: error_header =
'==>Error from '//trim(module_name)//
': '
422 character(len=35),
parameter :: warn_header =
'==>Warning from '//trim(module_name)//
': '
423 character(len=32),
parameter :: note_header =
'==>Note from '//trim(module_name)//
': '
424 character(len=1),
parameter :: comma =
","
425 character(len=1),
parameter :: list_sep =
'/'
427 character(len=1),
parameter :: comment =
'#'
428 character(len=1),
parameter :: dquote =
'"'
429 character(len=1),
parameter :: equal =
'='
430 character(len=1),
parameter :: squote =
"'"
432 integer,
parameter :: null_type = 0
433 integer,
parameter :: integer_type = 1
434 integer,
parameter :: list_type = 2
435 integer,
parameter :: logical_type = 3
436 integer,
parameter :: real_type = 4
437 integer,
parameter :: string_type = 5
438 integer,
parameter :: num_types = 5
439 integer,
parameter :: array_increment = 10
441 integer,
parameter :: MAX_FIELDS = maxfields_
442 integer,
parameter :: MAX_FIELD_METHODS = maxfieldmethods_
448 character(len=fm_field_name_len) :: field_type
449 character(len=fm_string_len) :: field_name
450 integer :: model, num_methods
459 character(len=fm_field_name_len) :: fld_type
460 character(len=fm_field_name_len) :: mod_name
461 character(len=fm_string_len) :: fld_name
467 character(len=fm_field_name_len) :: fld_type
468 character(len=fm_field_name_len) :: mod_name
474 character (len=fm_field_name_len) :: name
476 type (field_def),
pointer :: parent => null()
477 integer :: field_type
481 type (field_def),
pointer :: first_field => null()
482 type (field_def),
pointer :: last_field => null()
483 integer,
allocatable,
dimension(:) :: i_value
484 logical,
allocatable,
dimension(:) :: l_value
485 real(r8_kind),
allocatable,
dimension(:) :: r_value
487 character(len=fm_string_len),
allocatable,
dimension(:) :: s_value
488 type (
field_def),
pointer :: next => null()
489 type (
field_def),
pointer :: prev => null()
497 character(len=FMS_PATH_LEN) :: loop_list
498 character(len=fm_type_name_len) :: field_type_name(num_types)
499 character(len=fm_field_name_len) :: save_root_name
501 character(len=52) :: set =
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
504 character(len=50) :: set_nonexp =
"ABCDFGHIJKLMNOPQRSTUVWXYZabcdfghijklmnopqrstuvwxyz"
507 character(len=13) :: setnum =
"0123456789+-."
508 integer :: num_fields = 0
509 type (
field_def),
pointer :: loop_list_p => null()
510 type (
field_def),
pointer :: current_list_p => null()
511 type (
field_def),
pointer :: root_p => null()
512 type (
field_def),
pointer :: save_root_parent_p => null()
540 integer,
intent(out),
optional :: nfields
541 character(len=fm_string_len),
intent(in),
optional :: table_name
543 if (module_is_initialized)
then
544 if(
present(nfields)) nfields = num_fields
554 call mpp_error(fatal,
"You cannot have use_field_table_yaml=.true. without compiling with -Duse_yaml")
556 if (file_exists(
"field_table")) &
557 call mpp_error(fatal,
"You cannot have the legacy field_table if use_field_table_yaml=.true.")
559 call mpp_error(note,
"field_manager_init:: You are using the yaml version of the field_table")
563 if (file_exists(
"field_table.yaml")) &
564 call mpp_error(fatal,
"You cannot have the yaml field_table if use_field_table_yaml=.false.")
565 call mpp_error(note,
"field_manager_init:: You are using the legacy version of the field_table")
575 integer,
intent(out),
optional :: nfields
576 character(len=*),
intent(in),
optional :: table_name
578 character(len=FMS_FILE_LEN) :: tbl_name
579 character(len=fm_string_len) :: method_control
580 integer :: h, i, j, k, l, m
581 type (fmTable_t) :: my_table
583 character(len=FMS_PATH_LEN) :: list_name
584 character(len=fm_string_len) :: subparamvalue
585 character(len=fm_string_len) :: fm_yaml_null
586 integer :: current_field
587 integer :: index_list_name
588 integer :: subparamindex
589 logical :: fm_success
592 character(len=FMS_FILE_LEN) :: filename
594 if (.not.
PRESENT(table_name))
then
595 tbl_name =
'field_table.yaml'
597 tbl_name = trim(table_name)
600 call get_instance_filename(tbl_name, filename)
601 if (index(trim(filename),
"ens_") .ne. 0)
then
602 if (file_exists(filename) .and. file_exists(tbl_name)) &
603 call mpp_error(fatal,
"Both "//trim(tbl_name)//
" and "//trim(filename)//
" exists, pick one!")
607 if (.not. file_exists(filename)) filename = tbl_name
610 if (.not. file_exists(trim(filename)))
then
611 if(
present(nfields)) nfields = 0
618 do h=1,
size(my_table%types)
619 do i=1,
size(my_table%types(h)%models)
620 do j=1,
size(my_table%types(h)%models(i)%variables)
621 num_fields = num_fields + 1
626 allocate(
fields(num_fields))
629 do h=1,
size(my_table%types)
630 do i=1,
size(my_table%types(h)%models)
631 select case (my_table%types(h)%models(i)%name)
643 call mpp_error(fatal, trim(error_header)//
'The model name is unrecognised : &
644 &'//trim(my_table%types(h)%models(i)%name))
646 do j=1,
size(my_table%types(h)%models(i)%variables)
647 current_field = current_field + 1
648 list_name = list_sep//lowercase(trim(my_table%types(h)%models(i)%name))//list_sep//&
649 lowercase(trim(my_table%types(h)%name))//list_sep//&
650 lowercase(trim(my_table%types(h)%models(i)%variables(j)%name))
651 index_list_name =
fm_new_list(list_name, create = .true.)
652 if ( index_list_name ==
no_field ) &
653 call mpp_error(fatal, trim(error_header)//
'Could not set field list for '//trim(list_name))
655 fields(current_field)%model = model
656 fields(current_field)%field_name = lowercase(trim(my_table%types(h)%models(i)%variables(j)%name))
657 fields(current_field)%field_type = lowercase(trim(my_table%types(h)%name))
658 fields(current_field)%num_methods =
size(my_table%types(h)%models(i)%variables(j)%keys)
659 allocate(
fields(current_field)%methods(
fields(current_field)%num_methods))
660 if(
fields(current_field)%num_methods.gt.0)
then
661 subparams = (
size(my_table%types(h)%models(i)%variables(j)%attributes) .gt. 0)
662 do k=1,
size(my_table%types(h)%models(i)%variables(j)%keys)
663 fields(current_field)%methods(k)%method_type = &
664 lowercase(trim(my_table%types(h)%models(i)%variables(j)%keys(k)))
665 fields(current_field)%methods(k)%method_name = &
666 lowercase(trim(my_table%types(h)%models(i)%variables(j)%values(k)))
667 if (.not.subparams)
then
668 call new_name(list_name, my_table%types(h)%models(i)%variables(j)%keys(k),&
669 my_table%types(h)%models(i)%variables(j)%values(k) )
672 do l=1,
size(my_table%types(h)%models(i)%variables(j)%attributes)
673 if(lowercase(trim(my_table%types(h)%models(i)%variables(j)%attributes(l)%paramname)).eq.&
674 lowercase(trim(
fields(current_field)%methods(k)%method_type)))
then
679 if (subparamindex.eq.-1)
then
680 call new_name(list_name, my_table%types(h)%models(i)%variables(j)%keys(k),&
681 my_table%types(h)%models(i)%variables(j)%values(k) )
683 do m=1,
size(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%keys)
686 if (trim(my_table%types(h)%models(i)%variables(j)%values(k)).eq.
'fm_yaml_null')
then
689 fm_yaml_null = trim(my_table%types(h)%models(i)%variables(j)%values(k))//
'/'
691 method_control = trim(my_table%types(h)%models(i)%variables(j)%keys(k))//
"/"//&
692 &trim(fm_yaml_null)//&
693 &trim(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%keys(m))
694 subparamvalue = trim(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%values(m))
695 call new_name(list_name, method_control, subparamvalue)
705 if (
present(nfields)) nfields = num_fields
717 character(len=*),
intent(in) :: list_name
718 character(len=*),
intent(in) :: method_name_in
720 character(len=*),
intent(inout) :: val_name_in
723 character(len=fm_string_len) :: method_name
724 character(len=fm_string_len) :: val_name
725 integer,
dimension(:),
allocatable :: end_val
726 integer,
dimension(:),
allocatable :: start_val
732 logical :: append_new
734 real(r8_kind) :: val_real
738 method_name = trim(method_name_in)
748 do i = 1, len_trim(val_name_in)
749 if ( val_name_in(i:i) == comma )
then
750 num_elem = num_elem + 1
754 allocate(start_val(num_elem))
755 allocate(end_val(num_elem))
757 end_val(:) = len_trim(val_name_in)
760 do i = 1, len_trim(val_name_in)
761 if ( val_name_in(i:i) == comma )
then
762 end_val(num_elem) = i-1
763 start_val(num_elem+1) = i+1
764 num_elem = num_elem + 1
770 if ( i .gt. 1 .or. index_t .eq. 0 )
then
774 val_type = string_type
775 val_name = val_name_in(start_val(i):end_val(i))
778 if ( scan(val_name(1:1), setnum ) > 0 )
then
779 if ( scan(val_name, set_nonexp ) .le. 0 )
then
780 if ( scan(val_name,
'.') > 0 .or. scan(val_name,
'e') > 0 .or. scan(val_name,
'E') > 0)
then
781 read(val_name, *) val_real
784 read(val_name, *) val_int
785 val_type = integer_type
790 if ( len_trim(val_name) == 1 .or. len_trim(val_name) == 3)
then
791 if ( val_name ==
't' .or. val_name ==
'T' .or. val_name ==
'.t.' .or. val_name ==
'.T.' )
then
793 val_type = logical_type
795 if ( val_name ==
'f' .or. val_name ==
'F' .or. val_name ==
'.f.' .or. val_name ==
'.F.' )
then
797 val_type = logical_type
800 if ( trim(lowercase(val_name)) ==
'true' .or. trim(lowercase(val_name)) ==
'.true.' )
then
802 val_type = logical_type
804 if ( trim(lowercase(val_name)) ==
'false' .or. trim(lowercase(val_name)) ==
'.false.' )
then
806 val_type = logical_type
809 select case(val_type)
812 if (
fm_new_value( method_name, val_int, create = .true., index = index_t, append = append_new ) < 0 ) &
813 call mpp_error(fatal, trim(error_header)//
'Could not set "' // trim(val_name) //
'" for '//trim(method_name)//&
814 ' (I) for '//trim(list_name))
817 if (
fm_new_value( method_name, val_logic, create = .true., index = index_t, append = append_new) < 0 ) &
818 call mpp_error(fatal, trim(error_header)//
'Could not set "' // trim(val_name) //
'" for '//trim(method_name)//&
819 ' (L) for '//trim(list_name))
822 if (
fm_new_value( method_name, val_real, create = .true., index = index_t, append = append_new) < 0 ) &
823 call mpp_error(fatal, trim(error_header)//
'Could not set "' // trim(val_name) //
'" for '//trim(method_name)//&
824 ' (R) for '//trim(list_name))
827 if (
fm_new_value( method_name, val_name, create = .true., index = index_t, append = append_new) < 0 ) &
828 call mpp_error(fatal, trim(error_header)//
'Could not set "' // trim(val_name) //
'" for '//trim(method_name)//&
829 ' (S) for '//trim(list_name))
831 call mpp_error(fatal, trim(error_header)//
'Could not find a valid type to set the '//trim(method_name)//&
832 ' for '//trim(list_name))
837 deallocate(start_val)
852 integer,
intent(out),
optional :: nfields
853 character(len=fm_string_len),
intent(in),
optional :: table_name
856 character(len=1024) :: record
857 character(len=fm_string_len) :: control_str
858 character(len=FMS_PATH_LEN) :: list_name
859 character(len=fm_string_len) :: method_name
860 character(len=fm_string_len) :: name_str
861 character(len=fm_string_len) :: type_str
862 character(len=fm_string_len) :: val_name
863 character(len=fm_string_len) :: tbl_name
864 integer :: control_array(MAX_FIELDS,3)
867 integer :: index_list_name
877 logical :: flag_method
878 logical :: fm_success
885 if (.not.
PRESENT(table_name))
then
886 tbl_name =
'field_table'
888 tbl_name = trim(table_name)
890 if (.not. file_exists(trim(tbl_name)))
then
891 if(
present(nfields)) nfields = 0
895 allocate(
fields(max_fields))
897 open(newunit=iunit, file=trim(tbl_name), action=
'READ', iostat=io_status)
898 if(io_status/=0)
call mpp_error(fatal,
'field_manager_mod: Error in opening file '//trim(tbl_name))
903 read(iunit,
'(a)',
end=89,err=99) record
904 write( log_unit,
'(a)' )record
905 if (record(1:1) ==
"#" ) cycle
906 ltrec = len_trim(record)
907 if (ltrec .le. 0 ) cycle
912 if (record(l:l) ==
'"' )
then
916 if (icount > 6 )
then
917 call mpp_error(fatal,trim(error_header)//
'Too many fields in field table header entry.'//trim(record))
922 read(record,*,
end=79,err=79) text_names
923 text_names%fld_type = lowercase(trim(text_names%fld_type))
924 text_names%mod_name = lowercase(trim(text_names%mod_name))
925 text_names%fld_name = lowercase(trim(text_names%fld_name))
928 read(record,*,
end=79,err=79) text_names_short
929 text_names%fld_type = lowercase(trim(text_names_short%fld_type))
930 text_names%mod_name = lowercase(trim(text_names_short%mod_name))
931 text_names%fld_name = lowercase(trim(text_names_short%mod_name))
935 read(record,*,
end=79,err=79) text_names_short
936 text_names%fld_type = lowercase(trim(text_names_short%fld_type))
937 text_names%mod_name = lowercase(trim(text_names_short%mod_name))
938 text_names%fld_name = lowercase(trim(text_names_short%mod_name))
941 text_names%fld_type =
" "
942 text_names%mod_name = lowercase(trim(record))
943 text_names%fld_name =
" "
948 list_name = list_sep//trim(text_names%mod_name)//list_sep//trim(text_names%fld_type)//&
949 list_sep//trim(text_names%fld_name)
951 index_list_name =
fm_new_list(list_name, create = .true.)
952 if ( index_list_name ==
no_field ) &
953 call mpp_error(fatal, trim(error_header)//
'Could not set field list for '//trim(list_name))
956 select case (text_names%mod_name)
968 call mpp_error(fatal, trim(error_header)//
'The model name is unrecognised : '//trim(text_names%mod_name))
971 num_fields = num_fields + 1
973 if (num_fields > max_fields)
call mpp_error(fatal,trim(error_header)//
'max fields exceeded')
974 fields(num_fields)%model = model
975 fields(num_fields)%field_name = lowercase(trim(text_names%fld_name))
976 fields(num_fields)%field_type = lowercase(trim(text_names%fld_type))
977 fields(num_fields)%num_methods = 0
978 allocate(
fields(num_fields)%methods(max_field_methods))
979 call check_for_name_duplication
982 if ( record(len_trim(record):len_trim(record)) == list_sep) cycle
986 do while (flag_method)
987 read(iunit,
'(a)',
end=99,err=99) record
989 if (len_trim(record) .le. 0) cycle
991 if ( record(len_trim(record):len_trim(record)) == list_sep)
then
992 flag_method = .false.
993 if (len_trim(record) == 1) cycle
994 record = record(:len_trim(record)-1)
997 if (len_trim(record) .le. 0) cycle
999 if (record(1:1) == comment ) cycle
1002 do l= 1, len_trim(record)
1003 if (record(l:l) == dquote )
then
1007 if (icount > 6 )
call mpp_error(fatal,trim(error_header)//
'Too many fields in field entry.'//trim(record))
1010 call mpp_error(fatal, trim(error_header)//
'Could not change to '//trim(list_name)//
' list')
1012 select case (icount)
1014 read(record,*,
end=99,err=99) text_method
1015 fields(num_fields)%methods(m)%method_type = lowercase(trim(text_method%method_type))
1016 fields(num_fields)%methods(m)%method_name = lowercase(trim(text_method%method_name))
1017 fields(num_fields)%methods(m)%method_control = lowercase(trim(text_method%method_control))
1019 type_str = text_method%method_type
1020 name_str = text_method%method_name
1021 control_str = text_method%method_control
1025 read(record,*,
end=99,err=99) text_method_short
1026 fields(num_fields)%methods(m)%method_type =&
1027 & lowercase(trim(text_method_short%method_type))
1028 fields(num_fields)%methods(m)%method_name =&
1029 & lowercase(trim(text_method_short%method_name))
1030 fields(num_fields)%methods(m)%method_control =
" "
1032 type_str = text_method_short%method_type
1034 control_str = text_method_short%method_name
1039 read(record,*,
end=99,err=99) text_method_very_short
1040 fields(num_fields)%methods(m)%method_type = lowercase(trim(text_method_very_short%method_type))
1041 fields(num_fields)%methods(m)%method_name =
" "
1042 fields(num_fields)%methods(m)%method_control =
" "
1046 control_str = text_method_very_short%method_type
1049 read(record,
'(A)',
end=99,err=99) control_str
1054 call mpp_error(fatal,trim(error_header)//
'Unterminated field in field entry.'//trim(record))
1066 ltrec= len_trim(control_str)
1067 control_array(:,1) = 1
1068 control_array(:,2:3) = ltrec
1071 if (control_str(l:l) == equal )
then
1073 control_array(icount,2) = l
1074 elseif (control_str(l:l) == comma )
then
1075 if (icount .eq. 0)
then
1076 call mpp_error(fatal,trim(error_header) // &
1077 ' Bad format for field entry (comma without equals sign): ''' // &
1078 trim(control_str) //
'''')
1079 elseif (icount .gt. max_fields)
then
1080 call mpp_error(fatal,trim(error_header) // &
1081 ' Too many fields in field entry: ''' // &
1082 trim(control_str) //
'''')
1084 control_array(icount,3) = l-1
1085 control_array(min(max_fields,icount+1),1) = l+1
1094 if (control_str(ltrec:ltrec) .ne. comma)
then
1095 control_array(max(1,icount),3) = ltrec
1098 if ( icount == 0 )
then
1099 method_name = type_str
1100 if (len_trim(method_name) > 0 )
then
1101 method_name = trim(method_name)//list_sep// trim(name_str)
1103 method_name = trim(name_str)
1105 val_name = control_str
1107 call new_name(list_name, method_name, val_name )
1112 startcont = control_array(l,1)
1113 midcont = control_array(l,2)
1114 endcont = control_array(l,3)
1116 method_name = trim(type_str)
1117 if (len_trim(method_name) > 0 )
then
1118 method_name = trim(method_name)//list_sep// trim(name_str)
1120 method_name = trim(name_str)
1123 if (len_trim(method_name) > 0 )
then
1124 method_name = trim(method_name)//list_sep//&
1125 trim(control_str(startcont:midcont-1))
1127 method_name = trim(control_str(startcont:midcont-1))
1129 val_name = trim(control_str(midcont+1:endcont))
1131 call new_name(list_name, method_name, val_name )
1136 fields(num_fields)%num_methods =
fields(num_fields)%num_methods + 1
1137 if (
fields(num_fields)%num_methods > max_field_methods) &
1138 call mpp_error(fatal,trim(error_header)//
'Maximum number of methods for field exceeded')
1142 flag_method = .true.
1143 do while (flag_method)
1144 read(iunit,
'(A)',
end=99,err=99) record
1145 if ( record(len_trim(record):len_trim(record)) == list_sep)
then
1146 flag_method = .false.
1154 close(iunit, iostat=io_status)
1155 if(io_status/=0)
call mpp_error(fatal,
'field_manager_mod: Error in closing file '//trim(tbl_name))
1158 if(
present(nfields)) nfields = num_fields
1160 default_method%method_type =
'none'
1161 default_method%method_name =
'none'
1162 default_method%method_control =
'none'
1167 call mpp_error(fatal,trim(error_header)//
' Error reading field table. Record = '//trim(record))
1171 subroutine check_for_name_duplication
1176 if (
fields(i)%field_type ==
fields(num_fields)%field_type .and. &
1178 fields(i)%field_name ==
fields(num_fields)%field_name )
then
1179 if (
mpp_pe() .eq. mpp_root_pe())
then
1180 call mpp_error(warning,
'Error in field_manager_mod. Duplicate field name: Field type='//&
1181 trim(
fields(i)%field_type)// &
1183 ', Duplicated name='//trim(
fields(i)%field_name))
1188 end subroutine check_for_name_duplication
1198 subroutine new_name ( list_name, method_name_in , val_name_in)
1199 character(len=*),
intent(in) :: list_name
1200 character(len=*),
intent(in) :: method_name_in
1202 character(len=*),
intent(inout) :: val_name_in
1205 character(len=fm_string_len) :: method_name
1206 character(len=fm_string_len) :: val_name
1207 integer,
dimension(MAX_FIELDS) :: end_val
1208 integer,
dimension(MAX_FIELDS) :: start_val
1217 logical :: append_new
1218 logical :: val_logic
1219 real(r8_kind) :: val_real
1223 method_name = trim(method_name_in)
1228 append_new = .false.
1230 end_val(:) = len_trim(val_name_in)
1235 do i = 1, len_trim(val_name_in)
1236 if ( val_name_in(i:i) == comma )
then
1237 end_val(num_elem) = i-1
1238 start_val(num_elem+1) = i+1
1239 num_elem = num_elem + 1
1244 left_br = scan(method_name,
'[')
1245 right_br = scan(method_name,
']')
1246 if ( num_elem .eq. 1 )
then
1247 if ( left_br > 0 .and. right_br == 0 ) &
1248 call mpp_error(fatal, trim(error_header)//
"Left bracket present without right bracket in "//trim(method_name))
1249 if ( left_br== 0 .and. right_br > 0 ) &
1250 call mpp_error(fatal, trim(error_header)//
"Right bracket present without left bracket in "//trim(method_name))
1251 if ( left_br > 0 .and. right_br > 0 )
then
1252 if ( scan( method_name(left_br+1:right_br -1), set ) > 0 ) &
1253 call mpp_error(fatal, trim(error_header)//
"Using a non-numeric value for index in "//trim(method_name))
1254 read(method_name(left_br+1:right_br -1), *) index_t
1255 method_name = method_name(:left_br -1)
1259 if ( left_br > 0 .or. right_br > 0 ) &
1260 call mpp_error(fatal, &
1261 trim(error_header)//
"Using a comma delimited list with an indexed array element in "//trim(method_name))
1266 if ( i .gt. 1 .or. index_t .eq. 0 )
then
1270 val_type = string_type
1271 val_name = val_name_in(start_val(i):end_val(i))
1279 length = len_trim(val_name)
1280 if (val_name(1:1) .eq. squote)
then
1282 if (val_name(length:length) .eq. squote)
then
1283 val_name = val_name(2:length-1)//repeat(
" ",len(val_name)-length+2)
1284 val_type = string_type
1285 elseif (val_name(length:length) .eq. dquote)
then
1286 call mpp_error(fatal, trim(error_header) //
' Quotes do not match in ' // trim(val_name) // &
1287 ' for ' // trim(method_name) //
' of ' // trim(list_name))
1289 call mpp_error(fatal, trim(error_header) //
' No trailing quote in ' // trim(val_name) // &
1290 ' for ' // trim(method_name) //
' of ' // trim(list_name))
1293 elseif (val_name(1:1) .eq. dquote .or. val_name(length:length) .eq. dquote)
then
1295 call mpp_error(fatal, trim(error_header) //
' Double quotes not allowed in ' // trim(val_name) // &
1296 ' for ' // trim(method_name) //
' of ' // trim(list_name))
1298 elseif (val_name(length:length) .eq. squote)
then
1300 call mpp_error(fatal, trim(error_header) //
' No leading quote in ' // trim(val_name) // &
1301 ' for ' // trim(method_name) //
' of ' // trim(list_name))
1309 if ( scan(val_name(1:1), setnum ) > 0 )
then
1313 if ( scan(val_name, set_nonexp ) .le. 0 )
then
1315 if ( scan(val_name,
'.') > 0 .or. scan(val_name,
'e') > 0 .or. scan(val_name,
'E') > 0)
then
1316 read(val_name, *) val_real
1317 val_type = real_type
1319 read(val_name, *) val_int
1320 val_type = integer_type
1327 if ( len_trim(val_name) == 1 .or. len_trim(val_name) == 3)
then
1328 if ( val_name ==
't' .or. val_name ==
'T' .or. val_name ==
'.t.' .or. val_name ==
'.T.' )
then
1330 val_type = logical_type
1332 if ( val_name ==
'f' .or. val_name ==
'F' .or. val_name ==
'.f.' .or. val_name ==
'.F.' )
then
1334 val_type = logical_type
1337 if ( trim(lowercase(val_name)) ==
'true' .or. trim(lowercase(val_name)) ==
'.true.' )
then
1339 val_type = logical_type
1341 if ( trim(lowercase(val_name)) ==
'false' .or. trim(lowercase(val_name)) ==
'.false.' )
then
1343 val_type = logical_type
1347 select case(val_type)
1350 if (
fm_new_value( method_name, val_int, create = .true., index = index_t, append = append_new ) < 0 ) &
1351 call mpp_error(fatal, trim(error_header)//
'Could not set "' // trim(val_name) //
'" for '//trim(method_name)//&
1352 ' (I) for '//trim(list_name))
1355 if (
fm_new_value( method_name, val_logic, create = .true., index = index_t, append = append_new) < 0 ) &
1356 call mpp_error(fatal, trim(error_header)//
'Could not set "' // trim(val_name) //
'" for '//trim(method_name)//&
1357 ' (L) for '//trim(list_name))
1360 if (
fm_new_value( method_name, val_real, create = .true., index = index_t, append = append_new) < 0 ) &
1361 call mpp_error(fatal, trim(error_header)//
'Could not set "' // trim(val_name) //
'" for '//trim(method_name)//&
1362 ' (R) for '//trim(list_name))
1365 if (
fm_new_value( method_name, val_name, create = .true., index = index_t, append = append_new) < 0 ) &
1366 call mpp_error(fatal, trim(error_header)//
'Could not set "' // trim(val_name) //
'" for '//trim(method_name)//&
1367 ' (S) for '//trim(list_name))
1369 call mpp_error(fatal, trim(error_header)//
'Could not find a valid type to set the '//trim(method_name)//&
1370 ' for '//trim(list_name))
1385 module_is_initialized = .false.
1388 if(
allocated(
fields(j)%methods))
deallocate(
fields(j)%methods)
1399 character(len=*),
intent(inout) :: name
1401 name = trim(adjustl(name))
1413 integer,
intent(in) :: model
1414 character(len=*),
intent(in) :: field_name
1421 if (
fields(i)%model == model .and.
fields(i)%field_name == lowercase(field_name))
then
1433 character(len=*),
intent(in) :: field_name
1452 integer,
intent(in) :: n
1453 character (len=*),
intent(out) :: fld_type
1454 character (len=*),
intent(out) :: fld_name
1455 integer,
intent(out) :: model
1456 integer,
intent(out) :: num_methods
1458 if (n < 1 .or. n > num_fields)
call mpp_error(fatal,trim(error_header)//
'Invalid field index')
1460 fld_type =
fields(n)%field_type
1461 fld_name =
fields(n)%field_name
1463 num_methods =
fields(n)%num_methods
1473 integer,
intent(in) :: n
1474 integer,
intent(in) :: m
1477 if (n < 1 .or. n > num_fields)
call mpp_error(fatal,trim(error_header)//
'Invalid field index')
1478 if (m < 1 .or. m >
fields(n)%num_methods)
call mpp_error(fatal,trim(error_header)//
'Invalid method index')
1480 method =
fields(n)%methods(m)
1490 integer,
intent(in) :: n
1493 if (n < 1 .or. n > num_fields) &
1494 call mpp_error(fatal,trim(error_header)//
'Invalid field index')
1496 if (
size(methods(:)) <
fields(n)%num_methods) &
1497 call mpp_error(fatal,trim(error_header)//
'Method array too small')
1499 methods = default_method
1508 character(len=*),
intent(in) :: text
1509 character(len=*),
intent(in) :: label
1510 integer,
intent(out) :: values(:)
1516 character(len=*),
intent(in) :: text
1517 character(len=*),
intent(in) :: label
1518 character(len=*),
intent(out) :: values(:)
1524 character(len=*),
intent(in) :: text
1525 character(len=*),
intent(in) :: label
1526 integer,
intent(out) :: parse_ival
1529 integer :: values(1)
1532 if (
parse > 0) parse_ival = values(1)
1536 character(len=*),
intent(in) :: text
1537 character(len=*),
intent(in) :: label
1538 character(len=*),
intent(out) :: parse_sval
1541 character(len=len(parse_sval)) :: values(1)
1544 if (
parse > 0) parse_sval = values(1)
1561 character(len=*),
intent(in) :: name
1563 integer :: error, out_unit
1566 if (.not.
associated(parent_p) .or. name .eq.
' ')
then
1572 allocate(list_p, stat = error)
1573 if (error .ne. 0)
then
1574 write (out_unit,*) trim(error_header),
'Error ', error, &
1575 ' allocating memory for list ', trim(name)
1582 nullify(list_p%next)
1583 list_p%prev => parent_p%last_field
1584 nullify(list_p%first_field)
1585 nullify(list_p%last_field)
1587 list_p%field_type = null_type
1588 list_p%max_index = 0
1589 list_p%array_dim = 0
1590 if (
allocated(list_p%i_value))
deallocate(list_p%i_value)
1591 if (
allocated(list_p%l_value))
deallocate(list_p%l_value)
1592 if (
allocated(list_p%r_value))
deallocate(list_p%r_value)
1593 if (
allocated(list_p%s_value))
deallocate(list_p%s_value)
1596 if (parent_p%length .le. 0)
then
1597 parent_p%first_field => list_p
1599 parent_p%last_field%next => list_p
1602 parent_p%last_field => list_p
1604 parent_p%length = parent_p%length + 1
1606 list_p%index = parent_p%length
1608 list_p%parent => parent_p
1622 logical recursive function
dump_list(list_p,
recursive, depth, out_unit) result(success)
1625 logical,
intent(in) ::
recursive
1626 integer,
intent(in) :: depth
1628 integer,
intent(in) :: out_unit
1632 character(len=fm_field_name_len) :: num, scratch
1633 type (
field_def),
pointer :: this_field_p
1634 character(len=depth+fm_field_name_len) :: blank
1640 if (.not.
associated(list_p))
then
1642 elseif (list_p%field_type .ne. list_type)
then
1650 write (out_unit,
'(a,a,a)') blank(1:depth), trim(list_p%name), list_sep
1657 this_field_p => list_p%first_field
1659 do while (
associated(this_field_p))
1661 select case(this_field_p%field_type)
1666 success =
dump_list(this_field_p, .true., depthp1, out_unit)
1667 if (.not.success)
exit
1669 write (out_unit,
'(a,a,a)') blank(1:depthp1), trim(this_field_p%name), list_sep
1673 if (this_field_p%max_index .eq. 0)
then
1674 write (out_unit,
'(a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = NULL'
1675 elseif (this_field_p%max_index .eq. 1)
then
1676 write (scratch,*) this_field_p%i_value(1)
1677 write (out_unit,
'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = ', &
1678 trim(adjustl(scratch))
1680 do j = 1, this_field_p%max_index
1681 write (scratch,*) this_field_p%i_value(j)
1683 write (out_unit,
'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1684 '[', trim(adjustl(num)),
'] = ', trim(adjustl(scratch))
1689 if (this_field_p%max_index .eq. 0)
then
1690 write (out_unit,
'(a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = NULL'
1691 elseif (this_field_p%max_index .eq. 1)
then
1692 write (scratch,
'(l1)') this_field_p%l_value(1)
1693 write (out_unit,
'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = ', &
1694 trim(adjustl(scratch))
1696 do j = 1, this_field_p%max_index
1697 write (scratch,
'(l1)') this_field_p%l_value(j)
1699 write (out_unit,
'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1700 '[', trim(adjustl(num)),
'] = ', trim(adjustl(scratch))
1705 if (this_field_p%max_index .eq. 0)
then
1706 write (out_unit,
'(a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = NULL'
1707 elseif (this_field_p%max_index .eq. 1)
then
1708 write (scratch,*) this_field_p%r_value(1)
1709 write (out_unit,
'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = ', &
1710 trim(adjustl(scratch))
1712 do j = 1, this_field_p%max_index
1713 write (scratch,*) this_field_p%r_value(j)
1715 write (out_unit,
'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1716 '[', trim(adjustl(num)),
'] = ', trim(adjustl(scratch))
1721 if (this_field_p%max_index .eq. 0)
then
1722 write (out_unit,
'(a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = NULL'
1723 elseif (this_field_p%max_index .eq. 1)
then
1724 write (out_unit,
'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = ', &
1725 ''''//trim(this_field_p%s_value(1))//
''''
1727 do j = 1, this_field_p%max_index
1729 write (out_unit,
'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1730 '[', trim(adjustl(num)),
'] = ',
''''//trim(this_field_p%s_value(j))//
''''
1740 this_field_p => this_field_p%next
1753 character(len=*),
intent(in) :: name
1754 character(len=*),
intent(out) :: path
1755 character(len=*),
intent(out) :: base
1762 length = max(len_trim(name),0)
1763 if (length .eq. 0)
then
1770 do while (name(length:length) .eq. list_sep)
1772 if (length .eq. 0)
then
1776 if (length .eq. 0)
then
1783 i = index(name(1:length), list_sep, back = .true.)
1788 base = name(1:length)
1793 base = name(i+1:length)
1811 character(len=*),
intent(in) :: name
1812 type (
field_def),
pointer :: this_list_p
1815 type (
field_def),
pointer,
save :: temp_p
1820 if (name .eq.
'.')
then
1823 field_p => this_list_p
1824 elseif (name .eq.
'..')
then
1826 field_p => this_list_p%parent
1829 temp_p => this_list_p%first_field
1831 do while (
associated(temp_p))
1834 if (temp_p%name .eq. name)
then
1839 temp_p => temp_p%next
1855 character(len=*),
intent(in) :: name
1856 character(len=*),
intent(out) :: head
1857 character(len=*),
intent(out) :: rest
1861 i = index(name, list_sep)
1864 do while (i .le. len(name))
1865 if (name(i+1:i+1) .eq. list_sep)
then
1877 elseif (i .eq. len(name))
then
1902 character(len=*),
intent(in) :: path
1904 logical,
intent(in) :: create
1906 character(len=FMS_PATH_LEN) :: working_path
1907 character(len=FMS_PATH_LEN) :: rest
1908 character(len=fm_field_name_len) :: this_list
1909 integer :: i, out_unit
1910 type (
field_def),
pointer,
save :: working_path_p
1911 type (
field_def),
pointer,
save :: this_list_p
1916 if (path .eq.
' ')
then
1918 list_p => relative_p
1924 if (path(1:1) .eq. list_sep)
then
1925 working_path_p => root_p
1926 working_path = path(2:)
1928 working_path_p => relative_p
1932 do while (working_path .ne.
' ')
1934 call find_head(working_path, this_list, rest)
1937 if (this_list .eq.
' ')
then
1942 i = len_trim(this_list)
1943 do while (i .gt. 0 .and. this_list(i:i) .eq. list_sep)
1944 this_list(i:i) =
' '
1948 this_list_p =>
find_field(this_list, working_path_p)
1950 if (.not.
associated(this_list_p))
then
1953 this_list_p =>
make_list(working_path_p, this_list)
1954 if (.not.
associated(this_list_p))
then
1967 if (this_list_p%field_type .eq. list_type)
then
1968 working_path_p => this_list_p
1975 list_p => working_path_p
1990 character(len=*),
intent(in) :: name
1992 type (
field_def),
pointer,
save :: temp_p
1994 if (.not. module_is_initialized)
then
1998 temp_p =>
find_list(name, current_list_p, .false.)
2000 if (
associated(temp_p))
then
2001 current_list_p => temp_p
2022 character(len=*),
intent(in) :: name
2024 type (
field_def),
pointer,
save :: temp_list_p
2027 if (.not. module_is_initialized)
then
2032 if (name .eq.
' ')
then
2037 temp_list_p =>
find_list(name, current_list_p, .false.)
2039 if (
associated(temp_list_p))
then
2041 if (save_root_name .ne.
' ')
then
2042 root_p%name = save_root_name
2043 root_p%parent => save_root_parent_p
2046 root_p => temp_list_p
2048 save_root_name = root_p%name
2049 save_root_parent_p => root_p%parent
2052 nullify(root_p%parent)
2055 current_list_p => root_p
2071 character(len=*),
intent(in) :: name
2072 logical,
intent(in),
optional ::
recursive
2074 integer,
intent(in),
optional :: unit
2076 logical :: recursive_t
2077 type (
field_def),
pointer,
save :: temp_list_p
2080 if (
present(unit))
then
2086 recursive_t = .false.
2087 if (
present(
recursive)) recursive_t =
recursive
2090 if (name .eq.
' ')
then
2092 temp_list_p => current_list_p
2096 temp_list_p =>
find_list(name, current_list_p, .false.)
2097 if (
associated(temp_list_p))
then
2105 success =
dump_list(temp_list_p, recursive_t, 0, out_unit)
2117 character(len=*),
intent(in) :: name
2119 type (
field_def),
pointer,
save :: dummy_p
2121 if (.not. module_is_initialized)
then
2125 dummy_p =>
get_field(name, current_list_p)
2126 success =
associated(dummy_p)
2140 character(len=*),
intent(in) :: name
2142 type (
field_def),
pointer,
save :: temp_field_p
2147 if (.not. module_is_initialized)
then
2151 if (name .eq.
' ')
then
2156 temp_field_p =>
get_field(name, current_list_p)
2157 if (
associated(temp_field_p))
then
2159 index = temp_field_p%index
2173 character(len=FMS_PATH_LEN) :: path
2175 type (
field_def),
pointer,
save :: temp_list_p
2177 if (.not. module_is_initialized)
then
2182 temp_list_p => current_list_p
2185 do while (
associated(temp_list_p))
2188 if (temp_list_p%name .eq.
' ')
then
2192 path = list_sep // trim(temp_list_p%name) // path
2194 temp_list_p => temp_list_p%parent
2197 if (.not.
associated(temp_list_p))
then
2201 elseif (path .eq.
' ')
then
2218 character(len=*),
intent(in) :: name
2220 type (
field_def),
pointer,
save :: temp_field_p
2225 if (.not. module_is_initialized)
then
2229 if (name .eq.
' ')
then
2234 temp_field_p =>
get_field(name, current_list_p)
2236 if (
associated(temp_field_p))
then
2238 if (temp_field_p%field_type .eq. list_type)
then
2239 length = temp_field_p%length
2241 length = temp_field_p%max_index
2257 result(name_field_type)
2258 character(len=8) :: name_field_type
2259 character(len=*),
intent(in) :: name
2261 type (
field_def),
pointer,
save :: temp_field_p
2266 if (.not. module_is_initialized)
then
2270 if (name .eq.
' ')
then
2271 name_field_type =
' '
2275 temp_field_p =>
get_field(name, current_list_p)
2277 if (
associated(temp_field_p))
then
2279 name_field_type = field_type_name(temp_field_p%field_type)
2281 name_field_type =
' '
2291 character(len=*),
intent(in) :: name
2292 integer,
intent(out) :: get_ival
2293 integer,
intent(in),
optional :: index
2296 type (
field_def),
pointer,
save :: temp_field_p
2301 if (.not. module_is_initialized)
then
2305 if (name .eq.
' ')
then
2311 if (
present(index))
then
2317 temp_field_p =>
get_field(name, current_list_p)
2319 if (
associated(temp_field_p))
then
2321 if (temp_field_p%field_type .eq. integer_type)
then
2322 if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index)
then
2328 get_ival = temp_field_p%i_value(index_t)
2348 character(len=*),
intent(in) :: name
2349 logical,
intent(out) :: get_lval
2350 integer,
intent(in),
optional :: index
2353 type (
field_def),
pointer,
save :: temp_field_p
2358 if (.not. module_is_initialized)
then
2362 if (name .eq.
' ')
then
2368 if (
present(index))
then
2374 temp_field_p =>
get_field(name, current_list_p)
2376 if (
associated(temp_field_p))
then
2378 if (temp_field_p%field_type .eq. logical_type)
then
2380 if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index)
then
2386 get_lval = temp_field_p%l_value(index_t)
2406 character(len=*),
intent(in) :: name
2407 character(len=*),
intent(out) :: get_sval
2408 integer,
intent(in),
optional :: index
2411 type (
field_def),
pointer,
save :: temp_field_p
2416 if (.not. module_is_initialized)
then
2420 if (name .eq.
' ')
then
2426 if (
present(index))
then
2432 temp_field_p =>
get_field(name, current_list_p)
2434 if (
associated(temp_field_p))
then
2436 if (temp_field_p%field_type .eq. string_type)
then
2437 if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index)
then
2443 get_sval = temp_field_p%s_value(index_t)
2464 character(len=*),
intent(in) :: list
2465 character(len=*),
intent(out) :: name
2466 character(len=fm_type_name_len),
intent(out) :: field_type
2467 integer,
intent(out) :: index
2473 if (.not. module_is_initialized)
then
2477 if (list .eq. loop_list .and.
associated(loop_list_p))
then
2479 loop_list_p => loop_list_p%next
2481 elseif (list .eq.
' ')
then
2484 loop_list_p => current_list_p%first_field
2489 loop_list_p =>
find_list(loop_list, current_list_p, .false.)
2490 if (
associated(loop_list_p))
then
2491 loop_list_p => loop_list_p%first_field
2511 if (
associated(loop_list_p))
then
2512 name = loop_list_p%name
2513 field_type = field_type_name(loop_list_p%field_type)
2514 index = loop_list_p%index
2531 character(len=*) ,
intent(in) :: loop_list
2536 if (loop_list==
' ')
then
2537 iter%ptr => current_list_p%first_field
2539 iter%ptr =>
find_list(loop_list,current_list_p,.false.)
2540 if (
associated(iter%ptr)) iter%ptr => iter%ptr%first_field
2548 result(success) ;
logical success
2550 character(len=*),
intent(out) :: name
2551 character(len=*),
intent(out) :: field_type
2552 integer ,
intent(out) :: index
2555 if (
associated(iter%ptr))
then
2556 name = iter%ptr%name
2557 field_type = field_type_name(iter%ptr%field_type)
2558 index = iter%ptr%index
2560 iter%ptr => iter%ptr%next
2577 character(len=*),
intent(in) :: name
2578 logical,
intent(in),
optional :: create
2579 logical,
intent(in),
optional :: keep
2583 character(len=FMS_PATH_LEN) :: path
2584 character(len=fm_field_name_len) :: base
2585 type (
field_def),
pointer,
save :: temp_list_p
2590 if (.not. module_is_initialized)
then
2594 if (name .eq.
' ')
then
2599 if (
present(create))
then
2605 if (
present(keep))
then
2613 temp_list_p =>
find_list(path, current_list_p, create_t)
2615 if (
associated(temp_list_p))
then
2617 temp_list_p =>
make_list(temp_list_p, base)
2618 if (
associated(temp_list_p))
then
2621 current_list_p => temp_list_p
2623 index = temp_list_p%index
2637 integer :: field_index
2638 character(len=*),
intent(in) :: name
2640 integer,
intent(in) :: new_ival
2642 logical,
intent(in),
optional :: create
2644 integer,
intent(in),
optional :: index
2646 logical,
intent(in),
optional :: append
2652 integer,
pointer,
dimension(:) :: temp_i_value
2653 character(len=FMS_PATH_LEN) :: path
2654 character(len=fm_field_name_len) :: base
2655 type (
field_def),
pointer,
save :: temp_list_p
2656 type (
field_def),
pointer,
save :: temp_field_p
2661 if (.not. module_is_initialized)
then
2665 if (name .eq.
' ')
then
2670 if (
present(create))
then
2676 if (
present(index) .and.
present(append))
then
2677 if (append .and. index .gt. 0)
then
2683 if (
present(index))
then
2685 if (index_t .lt. 0)
then
2695 temp_list_p =>
find_list(path, current_list_p, create_t)
2697 if (
associated(temp_list_p))
then
2698 temp_field_p =>
find_field(base, temp_list_p)
2699 if (.not.
associated(temp_field_p))
then
2703 if (
associated(temp_field_p))
then
2706 if (temp_field_p%field_type == real_type )
then
2709 field_index =
fm_new_value(name, real(new_ival,r8_kind), create, index, append)
2711 else if (temp_field_p%field_type /= integer_type )
then
2714 temp_field_p%max_index = 0
2717 temp_field_p%field_type = integer_type
2719 if (
present(append))
then
2721 index_t = temp_field_p%max_index + 1
2725 if (index_t .gt. temp_field_p%max_index + 1)
then
2730 elseif (index_t .eq. 0 .and. &
2731 temp_field_p%max_index .gt. 0)
then
2736 elseif (.not.
allocated(temp_field_p%i_value) .and. &
2737 index_t .gt. 0)
then
2739 allocate(temp_field_p%i_value(1))
2740 temp_field_p%max_index = 1
2741 temp_field_p%array_dim = 1
2742 elseif (index_t .gt. temp_field_p%array_dim)
then
2745 temp_field_p%array_dim = temp_field_p%array_dim + array_increment
2746 allocate (temp_i_value(temp_field_p%array_dim))
2747 do i = 1, temp_field_p%max_index
2748 temp_i_value(i) = temp_field_p%i_value(i)
2750 if (
allocated(temp_field_p%i_value))
deallocate(temp_field_p%i_value)
2751 temp_field_p%i_value = temp_i_value
2752 temp_field_p%max_index = index_t
2756 if (index_t .gt. 0)
then
2757 temp_field_p%i_value(index_t) = new_ival
2758 if (index_t .gt. temp_field_p%max_index)
then
2759 temp_field_p%max_index = index_t
2762 field_index = temp_field_p%index
2777 integer :: field_index
2778 character(len=*),
intent(in) :: name
2780 logical,
intent(in) :: new_lval
2782 logical,
intent(in),
optional :: create
2784 integer,
intent(in),
optional :: index
2786 logical,
intent(in),
optional :: append
2789 character(len=FMS_PATH_LEN) :: path
2790 character(len=fm_field_name_len) :: base
2794 logical,
dimension(:),
pointer :: temp_l_value
2795 type (
field_def),
pointer,
save :: temp_list_p
2796 type (
field_def),
pointer,
save :: temp_field_p
2801 if (.not. module_is_initialized)
then
2805 if (name .eq.
' ')
then
2810 if (
present(create))
then
2816 if (
present(index) .and.
present(append))
then
2817 if (append .and. index .gt. 0)
then
2823 if (
present(index))
then
2825 if (index_t .lt. 0)
then
2835 temp_list_p =>
find_list(path, current_list_p, create_t)
2837 if (
associated(temp_list_p))
then
2838 temp_field_p =>
find_field(base, temp_list_p)
2839 if (.not.
associated(temp_field_p))
then
2843 if (
associated(temp_field_p))
then
2846 if (temp_field_p%field_type /= logical_type )
then
2847 temp_field_p%max_index = 0
2850 temp_field_p%field_type = logical_type
2852 if (
present(append))
then
2854 index_t = temp_field_p%max_index + 1
2858 if (index_t .gt. temp_field_p%max_index + 1)
then
2863 elseif (index_t .eq. 0 .and. &
2864 temp_field_p%max_index .gt. 0)
then
2869 elseif (.not.
allocated(temp_field_p%l_value) .and. &
2870 index_t .gt. 0)
then
2872 allocate(temp_field_p%l_value(1))
2873 temp_field_p%max_index = 1
2874 temp_field_p%array_dim = 1
2876 elseif (index_t .gt. temp_field_p%array_dim)
then
2879 temp_field_p%array_dim = temp_field_p%array_dim + array_increment
2880 allocate (temp_l_value(temp_field_p%array_dim))
2881 do i = 1, temp_field_p%max_index
2882 temp_l_value(i) = temp_field_p%l_value(i)
2884 if (
allocated(temp_field_p%l_value))
deallocate(temp_field_p%l_value)
2885 temp_field_p%l_value = temp_l_value
2886 temp_field_p%max_index = index_t
2891 if (index_t .gt. 0)
then
2892 temp_field_p%l_value(index_t) = new_lval
2893 if (index_t .gt. temp_field_p%max_index)
then
2894 temp_field_p%max_index = index_t
2897 field_index = temp_field_p%index
2911 integer :: field_index
2912 character(len=*),
intent(in) :: name
2914 character(len=*),
intent(in) :: new_sval
2916 logical,
intent(in),
optional :: create
2918 integer,
intent(in),
optional :: index
2920 logical,
intent(in),
optional :: append
2922 character(len=fm_string_len),
dimension(:),
pointer :: temp_s_value
2923 character(len=FMS_PATH_LEN) :: path
2924 character(len=fm_field_name_len) :: base
2928 type (
field_def),
save,
pointer :: temp_list_p
2929 type (
field_def),
save,
pointer :: temp_field_p
2934 if (.not. module_is_initialized)
then
2938 if (name .eq.
' ')
then
2943 if (
present(create))
then
2949 if (
present(index) .and.
present(append))
then
2950 if (append .and. index .gt. 0)
then
2956 if (
present(index))
then
2958 if (index_t .lt. 0)
then
2968 temp_list_p =>
find_list(path, current_list_p, create_t)
2970 if (
associated(temp_list_p))
then
2971 temp_field_p =>
find_field(base, temp_list_p)
2972 if (.not.
associated(temp_field_p))
then
2976 if (
associated(temp_field_p))
then
2979 if (temp_field_p%field_type /= string_type )
then
2980 temp_field_p%max_index = 0
2983 temp_field_p%field_type = string_type
2985 if (
present(append))
then
2987 index_t = temp_field_p%max_index + 1
2991 if (index_t .gt. temp_field_p%max_index + 1)
then
2996 elseif (index_t .eq. 0 .and. &
2997 temp_field_p%max_index .gt. 0)
then
3002 elseif (.not.
allocated(temp_field_p%s_value) .and. &
3003 index_t .gt. 0)
then
3005 allocate(temp_field_p%s_value(1))
3006 temp_field_p%max_index = 1
3007 temp_field_p%array_dim = 1
3009 elseif (index_t .gt. temp_field_p%array_dim)
then
3012 temp_field_p%array_dim = temp_field_p%array_dim + array_increment
3013 allocate (temp_s_value(temp_field_p%array_dim))
3014 do i = 1, temp_field_p%max_index
3015 temp_s_value(i) = temp_field_p%s_value(i)
3017 if (
allocated(temp_field_p%s_value))
deallocate(temp_field_p%s_value)
3018 temp_field_p%s_value = temp_s_value
3019 temp_field_p%max_index = index_t
3024 if (index_t .gt. 0)
then
3025 temp_field_p%s_value(index_t) = new_sval
3026 if (index_t .gt. temp_field_p%max_index)
then
3027 temp_field_p%max_index = index_t
3030 field_index = temp_field_p%index
3046 if (.not. module_is_initialized)
then
3051 nullify(loop_list_p)
3063 if (.not. module_is_initialized)
then
3067 root_p%name = save_root_name
3068 root_p%parent => save_root_parent_p
3072 save_root_name =
' '
3073 nullify(save_root_parent_p)
3083 character(len=*),
intent(in) :: name
3084 type (
field_def),
pointer :: this_list_p
3087 character(len=FMS_PATH_LEN) :: path
3088 character(len=fm_field_name_len) :: base
3089 type (
field_def),
pointer,
save :: temp_p
3095 if (path .ne.
' ')
then
3096 temp_p =>
find_list(path, this_list_p, .false.)
3097 if (
associated(temp_p))
then
3118 character(len=*),
intent(in) :: oldname
3120 character(len=*),
intent(in) :: newname
3123 character(len=FMS_PATH_LEN) :: path
3124 character(len=fm_field_name_len) :: base
3125 type (
field_def),
pointer,
save :: list_p
3126 type (
field_def),
pointer,
save :: temp_p
3131 if (path .ne.
' ')
then
3132 temp_p =>
find_list(path, current_list_p, .false.)
3133 if (
associated(temp_p))
then
3135 if (
associated(list_p))
then
3136 list_p%name = newname
3144 if (
associated(list_p))
then
3145 list_p%name = newname
3159 if (.not. module_is_initialized)
then
3161 read (input_nml_file, nml=field_manager_nml, iostat=io)
3162 ierr = check_nml_error(io,
"field_manager_nml")
3165 if (
mpp_pe() == mpp_root_pe())
write (logunit, nml=field_manager_nml)
3169 field_type_name(integer_type) =
'integer'
3170 field_type_name(list_type) =
'list'
3171 field_type_name(logical_type) =
'logical'
3172 field_type_name(real_type) =
'real'
3173 field_type_name(string_type) =
'string'
3177 root%parent => root_p
3179 root%field_type = list_type
3182 nullify(root%first_field)
3183 nullify(root%last_field)
3186 if (
allocated(root%i_value))
deallocate(root%i_value)
3187 if (
allocated(root%l_value))
deallocate(root%l_value)
3188 if (
allocated(root%r_value))
deallocate(root%r_value)
3189 if (
allocated(root%s_value))
deallocate(root%s_value)
3194 current_list_p => root
3196 nullify(loop_list_p)
3199 nullify(save_root_parent_p)
3200 save_root_name =
' '
3202 module_is_initialized = .true.
3216 type (
field_def),
pointer :: this_list_p
3217 character(len=*),
intent(in) :: name
3219 type (
field_def),
pointer,
save :: dummy_p
3227 if (
associated(dummy_p))
then
3235 if (.not.
associated(list_p))
then
3241 list_p%field_type = list_type
3242 if (
allocated(list_p%i_value))
deallocate(list_p%i_value)
3243 if (
allocated(list_p%l_value))
deallocate(list_p%l_value)
3244 if (
allocated(list_p%r_value))
deallocate(list_p%r_value)
3245 if (
allocated(list_p%s_value))
deallocate(list_p%s_value)
3260 character(len=*),
intent(in) :: name
3261 character(len=*),
intent(out) :: method_name
3262 character(len=*),
intent(out) :: method_control
3264 character(len=FMS_PATH_LEN) :: path
3265 character(len=FMS_PATH_LEN) :: base
3266 character(len=FMS_PATH_LEN) :: name_loc
3267 logical :: recursive_t
3268 type (
field_def),
pointer,
save :: temp_list_p
3269 type (
field_def),
pointer,
save :: temp_value_p
3270 type (
field_def),
pointer,
save :: this_field_p
3275 recursive_t = .true.
3277 method_control =
" "
3280 name_loc = lowercase(name)
3283 temp_list_p =>
find_list(name_loc, current_list_p, .false.)
3285 if (
associated(temp_list_p))
then
3287 success =
query_method(temp_list_p, recursive_t, base, method_name, method_control)
3292 temp_value_p =>
find_list(path, current_list_p, .false.)
3293 if (
associated(temp_value_p))
then
3295 this_field_p => temp_value_p%first_field
3297 do while (
associated(this_field_p))
3298 if ( this_field_p%name == base )
then
3299 method_name = this_field_p%s_value(1)
3306 this_field_p => this_field_p%next
3321 recursive function query_method(list_p, recursive, name, method_name, method_control) &
3325 logical,
intent(in) ::
recursive
3326 character(len=*),
intent(in) :: name
3327 character(len=*),
intent(out) :: method_name
3328 character(len=*),
intent(out) :: method_control
3331 character(len=64) :: scratch
3332 type (
field_def),
pointer :: this_field_p
3338 if (.not.
associated(list_p) .or. list_p%field_type .ne. list_type)
then
3345 this_field_p => list_p%first_field
3347 do while (
associated(this_field_p))
3348 select case(this_field_p%field_type)
3352 if (.not.
query_method(this_field_p, .true., this_field_p%name, method_name, method_control))
then
3356 method_name = trim(method_name)//trim(this_field_p%name)
3361 write (scratch,*) this_field_p%i_value
3362 call concat_strings(method_control, comma//trim(this_field_p%name)//
' = '//trim(adjustl(scratch)))
3365 write (scratch,
'(l1)')this_field_p%l_value
3366 call concat_strings(method_control, comma//trim(this_field_p%name)//
' = '//trim(adjustl(scratch)))
3369 write (scratch,*) this_field_p%r_value
3370 call concat_strings(method_control, comma//trim(this_field_p%name)//
' = '//trim(adjustl(scratch)))
3373 call concat_strings(method_control, comma//trim(this_field_p%name)//
' = '//trim(this_field_p%s_value(1)))
3374 do i = 2, this_field_p%max_index
3375 call concat_strings(method_control, comma//trim(this_field_p%s_value(i)))
3383 this_field_p => this_field_p%next
3391 character(*),
intent(inout) :: str1
3392 character(*),
intent(in) :: str2
3394 character(64) :: n1,n2
3396 if (len_trim(str1)+len_trim(str2)>len(str1))
then
3397 write(n1,*)len(str1)
3398 write(n2,*)len_trim(str1)+len_trim(str2)
3399 call mpp_error(fatal,
'length of output string ('//trim(adjustl(n1))&
3400 //
') is not enough for the result of concatenation (len='&
3401 //trim(adjustl(n2))//
')')
3403 str1 = trim(str1)//trim(str2)
3416 character(len=*),
intent(in) :: list_name
3417 character(len=*),
intent(in) :: suffix
3419 logical,
intent(in),
optional :: create
3421 character(len=fm_string_len),
dimension(:),
allocatable :: control
3422 character(len=fm_string_len),
dimension(:),
allocatable :: method
3423 character(len=fm_string_len) :: head
3424 character(len=fm_string_len) :: list_name_new
3425 character(len=fm_string_len) :: tail
3426 character(len=fm_string_len) :: val_str
3430 logical :: found_methods
3431 logical :: got_value
3432 logical :: recursive_t
3434 logical :: val_logical
3435 real(r8_kind) :: val_real
3436 type (
field_def),
pointer,
save :: temp_field_p
3437 type (
field_def),
pointer,
save :: temp_list_p
3444 list_name_new = trim(list_name)//trim(suffix)
3445 recursive_t = .true.
3447 if (.not. module_is_initialized)
then
3451 if (list_name .eq.
' ')
then
3453 temp_list_p => current_list_p
3457 temp_list_p =>
find_list(list_name, current_list_p, .false.)
3458 if (
associated(temp_list_p))
then
3468 do n = 1,
size(method)
3469 if (len_trim(method(n)) > 0 )
then
3470 index =
fm_new_list(trim(list_name_new)//list_sep//method(n), create = create)
3472 temp_field_p =>
find_list(trim(list_name)//list_sep//head,temp_list_p, .false.)
3473 temp_field_p =>
find_field(tail,temp_field_p)
3474 select case (temp_field_p%field_type)
3476 got_value =
fm_get_value( trim(list_name)//list_sep//method(n), val_int)
3477 if (
fm_new_value( trim(list_name_new)//list_sep//method(n), val_int, &
3478 create = create, append = .true.) < 0 ) &
3479 call mpp_error(fatal, trim(error_header)//
'Could not set the '//trim(method(n))//&
3480 ' for '//trim(list_name)//trim(suffix))
3483 got_value =
fm_get_value( trim(list_name)//list_sep//method(n), val_logical)
3484 if (
fm_new_value( trim(list_name_new)//list_sep//method(n), val_logical, &
3485 create = create, append = .true.) < 0 ) &
3486 call mpp_error(fatal, trim(error_header)//
'Could not set the '//trim(method(n))//&
3487 ' for '//trim(list_name)//trim(suffix))
3490 got_value =
fm_get_value( trim(list_name)//list_sep//method(n), val_real)
3491 if (
fm_new_value( trim(list_name_new)//list_sep//method(n), val_real, &
3492 create = create, append = .true.) < 0 ) &
3493 call mpp_error(fatal, trim(error_header)//
'Could not set the '//trim(method(n))//&
3494 ' for '//trim(list_name)//trim(suffix))
3497 got_value =
fm_get_value( trim(list_name)//list_sep//method(n), val_str)
3498 if (
fm_new_value( trim(list_name_new)//list_sep//method(n), val_str, &
3499 create = create, append = .true.) < 0 ) &
3500 call mpp_error(fatal, trim(error_header)//
'Could not set the '//trim(method(n))//&
3501 ' for '//trim(list_name)//trim(suffix))
3520 character(len=*),
intent(in) :: list_name
3521 character(len=*),
intent(out),
dimension(:) :: methods
3522 character(len=*),
intent(out),
dimension(:) :: control
3525 logical :: recursive_t
3526 type (
field_def),
pointer,
save :: temp_list_p
3532 recursive_t = .true.
3534 if (.not. module_is_initialized)
then
3538 if (list_name .eq.
' ')
then
3540 temp_list_p => current_list_p
3544 temp_list_p =>
find_list(list_name, current_list_p, .false.)
3545 if (
associated(temp_list_p))
then
3554 success =
find_method(temp_list_p, recursive_t, num_meth, methods, control)
3563 recursive function find_method(list_p, recursive, num_meth, method, control) &
3567 logical,
intent(in) ::
recursive
3568 integer,
intent(inout) :: num_meth
3569 character(len=*),
intent(out),
dimension(:) :: method
3570 character(len=*),
intent(out),
dimension(:) :: control
3572 character(len=FMS_PATH_LEN) :: scratch
3575 type (
field_def),
pointer,
save :: this_field_p
3580 if (.not.
associated(list_p) .or. list_p%field_type .ne. list_type)
then
3586 this_field_p => list_p%first_field
3588 do while (
associated(this_field_p))
3589 select case(this_field_p%field_type)
3592 if ( this_field_p%length > 1)
then
3593 do n = num_meth+1, num_meth + this_field_p%length - 1
3594 write (method(n),
'(a,a,a,$)') trim(method(num_meth)), &
3595 trim(this_field_p%name), list_sep
3597 write (method(num_meth),
'(a,a,a,$)') trim(method(num_meth)), &
3598 trim(this_field_p%name), list_sep
3600 write (method(num_meth),
'(a,a,a,$)') trim(method(num_meth)), &
3601 trim(this_field_p%name), list_sep
3603 success =
find_method(this_field_p, .true., num_meth, method, control)
3606 write (scratch,*) this_field_p%i_value
3608 write (method(num_meth),
'(a,a)') trim(method(num_meth)), &
3609 trim(this_field_p%name)
3610 write (control(num_meth),
'(a)') &
3612 num_meth = num_meth + 1
3617 write (method(num_meth),
'(a,a)') trim(method(num_meth)), &
3618 trim(this_field_p%name)
3619 write (control(num_meth),
'(l1)') &
3620 this_field_p%l_value
3621 num_meth = num_meth + 1
3625 if(
allocated(this_field_p%r_value))
write (scratch,*) this_field_p%r_value
3627 write (method(num_meth),
'(a,a)') trim(method(num_meth)), &
3628 trim(this_field_p%name)
3629 write (control(num_meth),
'(a)') &
3631 num_meth = num_meth + 1
3635 write (method(num_meth),
'(a,a)') trim(method(num_meth)), &
3636 trim(this_field_p%name)
3637 write (control(num_meth),
'(a)') &
3638 trim(this_field_p%s_value(1))
3639 do i = 2, this_field_p%max_index
3640 write (control(num_meth),
'(a,a,$)') comma//trim(this_field_p%s_value(i))
3642 num_meth = num_meth + 1
3651 this_field_p => this_field_p%next
3657 #include "field_manager_r4.fh"
3658 #include "field_manager_r8.fh"
3660 end module field_manager_mod
integer function parse_integer(text, label, parse_ival)
integer function, public fm_copy_list(list_name, suffix, create)
A function that allows the user to copy a field and add a suffix to the name of the new field.
type(field_def) function, pointer, private find_list(path, relative_p, create)
Find and return a pointer to the specified list, relative to relative_p. Return a null pointer on err...
recursive logical function query_method(list_p, recursive, name, method_name, method_control)
A private function that can recursively recover values for parameters associated with a field.
subroutine, private find_base(name, path, base)
A subroutine that splits a listname into a path and a base.
integer function fm_new_value_integer(name, new_ival, create, index, append)
Assigns a given value to a given field.
integer, parameter, public fm_string_len
The length of a character string representing character values for the field.
integer function fm_new_value_logical(name, new_lval, create, index, append)
Assigns a given value to a given field.
logical function set_list_stuff()
If the pointer matches to the right list, extract the field information. Used in fm_loop_over_list.
type(field_def) function, pointer, private create_field(parent_p, name)
A function to create a field as a child of parent_p. This will return a pointer to a field_def type.
subroutine strip_front_blanks(name)
A routine to strip whitespace from the start of character strings.
integer, parameter, public model_land
Land model.
function parse_strings(text, label, values)
subroutine concat_strings(str1, str2)
private function: appends str2 to the end of str1, with length check
integer function find_field_index_new(field_name)
integer function, public fm_get_length(name)
A function to return how many elements are contained within the named list or entry.
logical function fm_get_value_integer(name, get_ival, index)
character(len=8) function, public fm_get_type(name)
A function to return the type of the named field.
subroutine, public fm_reset_loop
Resets the loop variable. For use in conjunction with fm_loop_over_list.
logical function, public fm_exists(name)
A function to test whether a named field exists.
character(len=11), dimension(num_models), parameter, public model_names
Model names, e.g. MODEL_NAMES(MODEL_OCEAN) is 'oceanic'.
logical function, public fm_change_list(name)
Change the current list. Return true on success, false otherwise.
subroutine read_field_table_yaml(nfields, table_name)
Routine to read and parse the field table yaml.
integer function, public fm_new_list(name, create, keep)
A function to create a new list.
type(field_mgr_type), dimension(:), allocatable, private fields
fields of field_mgr_type
subroutine, public get_field_methods(n, methods)
A routine to obtain all the methods associated with a field.
character(len=fms_path_len) function, public fm_get_current_list()
A function to return the full path of the current list.
subroutine, private find_head(name, head, rest)
Find the first list for a name by splitting the name into a head and the rest.
integer function, public fm_get_index(name)
A function to return the index of a named field.
subroutine, public field_manager_end
Destructor for field manager.
integer function find_field_index_old(model, field_name)
Function to return the index of the field.
subroutine new_name_yaml(list_name, method_name_in, val_name_in)
Subroutine to add new values to list parameters.
type(field_def) function, pointer, private get_field(name, this_list_p)
Return a pointer to the field if it exists relative to this_list_p, null otherwise.
subroutine, public field_manager_init(nfields, table_name)
Routine to initialize the field manager.
logical function, public fm_query_method(name, method_name, method_control)
This is a function that provides the capability to return parameters associated with a field in a pai...
integer, parameter, public model_coupler
Ice model.
subroutine, private initialize_module_variables
A function to initialize the values of the pointers. This will remove all fields and reset the field ...
integer, parameter, public fm_field_name_len
The length of a character string representing the field name.
type(field_def) function, pointer, private make_list(this_list_p, name)
This function creates a new field and returns a pointer to that field.
recursive logical function find_method(list_p, recursive, num_meth, method, control)
Given a field list pointer this function retrieves methods and associated parameters for the field li...
subroutine, public get_field_method(n, m, method)
A routine to get a specified method.
subroutine, public get_field_info(n, fld_type, fld_name, model, num_methods)
This routine allows access to field information given an index.
logical function fm_get_value_logical(name, get_lval, index)
integer, parameter, public fm_type_name_len
The length of a character string representing the various types that the values of the field can take...
logical use_field_table_yaml
.True. if using the field_table.yaml, .false. if using the legacy field_table
subroutine read_field_table_legacy(nfields, table_name)
Routine to read and parse the field table yaml.
logical function, public fm_modify_name(oldname, newname)
This function allows a user to rename a field without modifying the contents of the field.
logical function, public fm_dump_list(name, recursive, unit)
A function to list properties associated with a field.
logical recursive function, private dump_list(list_p, recursive, depth, out_unit)
This is a function that lists the parameters of a field.
integer, parameter, public model_ocean
Ocean model.
subroutine, public fm_return_root
Return the root list to the value at initialization.
integer, parameter, public no_field
The value returned if a field is not defined.
subroutine, public fm_init_loop(loop_list, iter)
given a name of the list, prepares an iterator over the list content. If the name of the given list i...
function parse_integers(text, label, values)
logical function fm_loop_over_list_new(iter, name, field_type, index)
given a list iterator, returns information about curren list element and advances the iterator to the...
integer, parameter, public model_ice
Ice model.
integer function fm_new_value_string(name, new_sval, create, index, append)
Assigns a given value to a given field.
logical function, public fm_change_root(name)
Change the root list.
subroutine new_name(list_name, method_name_in, val_name_in)
Subroutine to add new values to list parameters.
integer function parse_string(text, label, parse_sval)
integer, parameter, public model_atmos
Atmospheric model.
integer, parameter, public num_models
Number of models (ATMOS, OCEAN, LAND, ICE, COUPLER).
type(field_def) function, pointer, private find_field(name, this_list_p)
Find and return a pointer to the field in the specified list. Return a null pointer on error.
logical function, public fm_find_methods(list_name, methods, control)
This function retrieves all the methods associated with a field.
logical function fm_loop_over_list_old(list, name, field_type, index)
Iterates through the given list.
logical function fm_get_value_string(name, get_sval, index)
Returns an index corresponding to the given field name.
An overloaded function to find and extract a value for a named field.
A function for looping over a list.
An overloaded function to assign a value to a field.
A function to parse an integer or an array of integers, a real or an array of reals,...
Private type for internal use.
Private type for internal use.
Private type for internal use.
Private type for internal use.
Iterator over the field manager list.
This method_type is a way to allow a component module to alter the parameters it needs for various tr...
This method_type is the same as method_type except that the method_control string is not present....
This is the same as method_type except that the method_control and method_name strings are not presen...
subroutine, public build_fmtable(fmTable, filename)
Subroutine to populate an fmTable by reading a yaml file, given an optional filename.
integer function, public check_nml_error(IOSTAT, NML_NAME)
Checks the iostat argument that is returned after reading a namelist and determines if the error code...
subroutine, public write_version_number(version, tag, unit)
Prints to the log file (or a specified unit) the version id string and tag name.
integer function stdout()
This function returns the current standard fortran unit numbers for output.
integer function stdlog()
This function returns the current standard fortran unit numbers for log messages. Log messages,...
integer function mpp_pe()
Returns processor ID.