157module field_manager_mod
160#define MAXFIELDS_ 250
164#ifndef MAXFIELDMETHODS_
165#define MAXFIELDMETHODS_ 250
190use fms_mod,
only : lowercase, &
191 write_version_number, &
193use fms2_io_mod,
only: file_exists, get_instance_filename
194use platform_mod,
only: r4_kind, r8_kind, fms_path_len, fms_file_len
202#include<file_version.h>
203logical :: module_is_initialized = .false.
272character(len=11),
parameter,
public,
dimension(NUM_MODELS) :: &
273 model_names=(/
'atmospheric',
'oceanic ',
'land ',
'ice ',
'coupler '/)
293 character(len=fm_string_len) :: method_name
296 character(len=fm_string_len) :: method_control
307 character(len=fm_string_len) :: method_type
308 character(len=fm_string_len) :: method_name
317 character(len=fm_string_len) :: method_type
358 module procedure parse_real_r4
359 module procedure parse_real_r8
360 module procedure parse_reals_r4
361 module procedure parse_reals_r8
387 module procedure fm_new_value_real_r4
388 module procedure fm_new_value_real_r8
406 module procedure fm_get_value_real_r4
407 module procedure fm_get_value_real_r8
425character(len=17),
parameter :: module_name =
'field_manager_mod'
426character(len=33),
parameter :: error_header =
'==>Error from '//trim(module_name)//
': '
427character(len=35),
parameter :: warn_header =
'==>Warning from '//trim(module_name)//
': '
428character(len=32),
parameter :: note_header =
'==>Note from '//trim(module_name)//
': '
429character(len=1),
parameter :: comma =
","
430character(len=1),
parameter :: list_sep =
'/'
432character(len=1),
parameter :: comment =
'#'
433character(len=1),
parameter :: dquote =
'"'
434character(len=1),
parameter :: equal =
'='
435character(len=1),
parameter :: squote =
"'"
437integer,
parameter :: null_type = 0
438integer,
parameter :: integer_type = 1
439integer,
parameter :: list_type = 2
440integer,
parameter :: logical_type = 3
441integer,
parameter :: real_type = 4
442integer,
parameter :: string_type = 5
443integer,
parameter :: num_types = 5
444integer,
parameter :: array_increment = 10
446integer,
parameter :: MAX_FIELDS = maxfields_
447integer,
parameter :: MAX_FIELD_METHODS = maxfieldmethods_
453 character(len=fm_field_name_len) :: field_type
454 character(len=fm_string_len) :: field_name
455 integer :: model, num_methods
464 character(len=fm_field_name_len) :: fld_type
465 character(len=fm_field_name_len) :: mod_name
466 character(len=fm_string_len) :: fld_name
472 character(len=fm_field_name_len) :: fld_type
473 character(len=fm_field_name_len) :: mod_name
479 character (len=fm_field_name_len) :: name
481 type (field_def),
pointer :: parent => null()
482 integer :: field_type
486 type (field_def),
pointer :: first_field => null()
487 type (field_def),
pointer :: last_field => null()
488 integer,
allocatable,
dimension(:) :: i_value
489 logical,
allocatable,
dimension(:) :: l_value
490 real(r8_kind),
allocatable,
dimension(:) :: r_value
492 character(len=fm_string_len),
allocatable,
dimension(:) :: s_value
493 type (
field_def),
pointer :: next => null()
494 type (
field_def),
pointer :: prev => null()
502character(len=FMS_PATH_LEN) :: loop_list
503character(len=fm_type_name_len) :: field_type_name(num_types)
504character(len=fm_field_name_len) :: save_root_name
506character(len=52) :: set =
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
509character(len=50) :: set_nonexp =
"ABCDFGHIJKLMNOPQRSTUVWXYZabcdfghijklmnopqrstuvwxyz"
512character(len=13) :: setnum =
"0123456789+-."
513integer :: num_fields = 0
514type (
field_def),
pointer :: loop_list_p => null()
515type (
field_def),
pointer :: current_list_p => null()
516type (
field_def),
pointer :: root_p => null()
517type (
field_def),
pointer :: save_root_parent_p => null()
545integer,
intent(out),
optional :: nfields
546character(len=fm_string_len),
intent(in),
optional :: table_name
548if (module_is_initialized)
then
549 if(
present(nfields)) nfields = num_fields
559 call mpp_error(fatal,
"You cannot have use_field_table_yaml=.true. without compiling with -Duse_yaml")
561 if (file_exists(
"field_table")) &
562 call mpp_error(fatal,
"You cannot have the legacy field_table if use_field_table_yaml=.true.")
564 call mpp_error(note,
"You are using the yaml version of the field_table")
568 if (file_exists(
"field_table.yaml")) &
569 call mpp_error(fatal,
"You cannot have the yaml field_table if use_field_table_yaml=.false.")
570 call mpp_error(note,
"You are using the legacy version of the field_table")
580integer,
intent(out),
optional :: nfields
581character(len=*),
intent(in),
optional :: table_name
583character(len=FMS_FILE_LEN) :: tbl_name
584character(len=fm_string_len) :: method_control
585integer :: h, i, j, k, l, m
586type (fmTable_t) :: my_table
588character(len=FMS_PATH_LEN) :: list_name
589character(len=fm_string_len) :: subparamvalue
590character(len=fm_string_len) :: fm_yaml_null
591integer :: current_field
592integer :: index_list_name
593integer :: subparamindex
597character(len=FMS_FILE_LEN) :: filename
599if (.not.
PRESENT(table_name))
then
600 tbl_name =
'field_table.yaml'
602 tbl_name = trim(table_name)
605call get_instance_filename(tbl_name, filename)
606if (index(trim(filename),
"ens_") .ne. 0)
then
607 if (file_exists(filename) .and. file_exists(tbl_name)) &
608 call mpp_error(fatal,
"Both "//trim(tbl_name)//
" and "//trim(filename)//
" exists, pick one!")
612 if (.not. file_exists(filename)) filename = tbl_name
615if (.not. file_exists(trim(filename)))
then
616 if(
present(nfields)) nfields = 0
623do h=1,
size(my_table%types)
624 do i=1,
size(my_table%types(h)%models)
625 do j=1,
size(my_table%types(h)%models(i)%variables)
626 num_fields = num_fields + 1
631allocate(
fields(num_fields))
634do h=1,
size(my_table%types)
635 do i=1,
size(my_table%types(h)%models)
636 select case (my_table%types(h)%models(i)%name)
648 call mpp_error(fatal, trim(error_header)//
'The model name is unrecognised : &
649 &'//trim(my_table%types(h)%models(i)%name))
651 do j=1,
size(my_table%types(h)%models(i)%variables)
652 current_field = current_field + 1
653 list_name = list_sep//lowercase(trim(my_table%types(h)%models(i)%name))//list_sep//&
654 lowercase(trim(my_table%types(h)%name))//list_sep//&
655 lowercase(trim(my_table%types(h)%models(i)%variables(j)%name))
656 index_list_name =
fm_new_list(list_name, create = .true.)
657 if ( index_list_name ==
no_field ) &
658 call mpp_error(fatal, trim(error_header)//
'Could not set field list for '//trim(list_name))
660 fields(current_field)%model = model
661 fields(current_field)%field_name = lowercase(trim(my_table%types(h)%models(i)%variables(j)%name))
662 fields(current_field)%field_type = lowercase(trim(my_table%types(h)%name))
663 fields(current_field)%num_methods =
size(my_table%types(h)%models(i)%variables(j)%keys)
664 allocate(
fields(current_field)%methods(
fields(current_field)%num_methods))
665 if(
fields(current_field)%num_methods.gt.0)
then
666 subparams = (
size(my_table%types(h)%models(i)%variables(j)%attributes) .gt. 0)
667 do k=1,
size(my_table%types(h)%models(i)%variables(j)%keys)
668 fields(current_field)%methods(k)%method_type = &
669 lowercase(trim(my_table%types(h)%models(i)%variables(j)%keys(k)))
670 fields(current_field)%methods(k)%method_name = &
671 lowercase(trim(my_table%types(h)%models(i)%variables(j)%values(k)))
672 if (.not.subparams)
then
673 call new_name(list_name, my_table%types(h)%models(i)%variables(j)%keys(k),&
674 my_table%types(h)%models(i)%variables(j)%values(k) )
677 do l=1,
size(my_table%types(h)%models(i)%variables(j)%attributes)
678 if(lowercase(trim(my_table%types(h)%models(i)%variables(j)%attributes(l)%paramname)).eq.&
679 lowercase(trim(
fields(current_field)%methods(k)%method_type)))
then
684 if (subparamindex.eq.-1)
then
685 call new_name(list_name, my_table%types(h)%models(i)%variables(j)%keys(k),&
686 my_table%types(h)%models(i)%variables(j)%values(k) )
688 do m=1,
size(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%keys)
691 if (trim(my_table%types(h)%models(i)%variables(j)%values(k)).eq.
'fm_yaml_null')
then
694 fm_yaml_null = trim(my_table%types(h)%models(i)%variables(j)%values(k))//
'/'
696 method_control = trim(my_table%types(h)%models(i)%variables(j)%keys(k))//
"/"//&
697 &trim(fm_yaml_null)//&
698 &trim(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%keys(m))
699 subparamvalue = trim(my_table%types(h)%models(i)%variables(j)%attributes(subparamindex)%values(m))
700 call new_name(list_name, method_control, subparamvalue)
710if (
present(nfields)) nfields = num_fields
722character(len=*),
intent(in) :: list_name
723character(len=*),
intent(in) :: method_name_in
725character(len=*),
intent(inout) :: val_name_in
728character(len=fm_string_len) :: method_name
729character(len=fm_string_len) :: val_name
730integer,
dimension(:),
allocatable :: end_val
731integer,
dimension(:),
allocatable :: start_val
739real(r8_kind) :: val_real
743method_name = trim(method_name_in)
753do i = 1, len_trim(val_name_in)
754 if ( val_name_in(i:i) == comma )
then
755 num_elem = num_elem + 1
759allocate(start_val(num_elem))
760allocate(end_val(num_elem))
762end_val(:) = len_trim(val_name_in)
765do i = 1, len_trim(val_name_in)
766 if ( val_name_in(i:i) == comma )
then
767 end_val(num_elem) = i-1
768 start_val(num_elem+1) = i+1
769 num_elem = num_elem + 1
775 if ( i .gt. 1 .or. index_t .eq. 0 )
then
779 val_type = string_type
780 val_name = val_name_in(start_val(i):end_val(i))
783 if ( scan(val_name(1:1), setnum ) > 0 )
then
784 if ( scan(val_name, set_nonexp ) .le. 0 )
then
785 if ( scan(val_name,
'.') > 0 .or. scan(val_name,
'e') > 0 .or. scan(val_name,
'E') > 0)
then
786 read(val_name, *) val_real
789 read(val_name, *) val_int
790 val_type = integer_type
795 if ( len_trim(val_name) == 1 .or. len_trim(val_name) == 3)
then
796 if ( val_name ==
't' .or. val_name ==
'T' .or. val_name ==
'.t.' .or. val_name ==
'.T.' )
then
798 val_type = logical_type
800 if ( val_name ==
'f' .or. val_name ==
'F' .or. val_name ==
'.f.' .or. val_name ==
'.F.' )
then
802 val_type = logical_type
805 if ( trim(lowercase(val_name)) ==
'true' .or. trim(lowercase(val_name)) ==
'.true.' )
then
807 val_type = logical_type
809 if ( trim(lowercase(val_name)) ==
'false' .or. trim(lowercase(val_name)) ==
'.false.' )
then
811 val_type = logical_type
814 select case(val_type)
817 if (
fm_new_value( method_name, val_int, 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 ' (I) for '//trim(list_name))
822 if (
fm_new_value( method_name, val_logic, 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 ' (L) for '//trim(list_name))
827 if (
fm_new_value( method_name, val_real, 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 ' (R) for '//trim(list_name))
832 if (
fm_new_value( method_name, val_name, create = .true., index = index_t, append = append_new) < 0 ) &
833 call mpp_error(fatal, trim(error_header)//
'Could not set "' // trim(val_name) //
'" for '//trim(method_name)//&
834 ' (S) for '//trim(list_name))
836 call mpp_error(fatal, trim(error_header)//
'Could not find a valid type to set the '//trim(method_name)//&
837 ' for '//trim(list_name))
842 deallocate(start_val)
857integer,
intent(out),
optional :: nfields
858character(len=fm_string_len),
intent(in),
optional :: table_name
861character(len=1024) :: record
862character(len=fm_string_len) :: control_str
863character(len=FMS_PATH_LEN) :: list_name
864character(len=fm_string_len) :: method_name
865character(len=fm_string_len) :: name_str
866character(len=fm_string_len) :: type_str
867character(len=fm_string_len) :: val_name
868character(len=fm_string_len) :: tbl_name
869integer :: control_array(MAX_FIELDS,3)
872integer :: index_list_name
882logical :: flag_method
890if (.not.
PRESENT(table_name))
then
891 tbl_name =
'field_table'
893 tbl_name = trim(table_name)
895if (.not. file_exists(trim(tbl_name)))
then
896 if(
present(nfields)) nfields = 0
900allocate(
fields(max_fields))
902open(newunit=iunit, file=trim(tbl_name), action=
'READ', iostat=io_status)
903if(io_status/=0)
call mpp_error(fatal,
'field_manager_mod: Error in opening file '//trim(tbl_name))
905call write_version_number(
"FIELD_MANAGER_MOD", version)
908 read(iunit,
'(a)',
end=89,err=99) record
909 write( log_unit,
'(a)' )record
910 if (record(1:1) ==
"#" ) cycle
911 ltrec = len_trim(record)
912 if (ltrec .le. 0 ) cycle
917 if (record(l:l) ==
'"' )
then
921 if (icount > 6 )
then
922 call mpp_error(fatal,trim(error_header)//
'Too many fields in field table header entry.'//trim(record))
927 read(record,*,
end=79,err=79) text_names
928 text_names%fld_type = lowercase(trim(text_names%fld_type))
929 text_names%mod_name = lowercase(trim(text_names%mod_name))
930 text_names%fld_name = lowercase(trim(text_names%fld_name))
933 read(record,*,
end=79,err=79) text_names_short
934 text_names%fld_type = lowercase(trim(text_names_short%fld_type))
935 text_names%mod_name = lowercase(trim(text_names_short%mod_name))
936 text_names%fld_name = lowercase(trim(text_names_short%mod_name))
940 read(record,*,
end=79,err=79) text_names_short
941 text_names%fld_type = lowercase(trim(text_names_short%fld_type))
942 text_names%mod_name = lowercase(trim(text_names_short%mod_name))
943 text_names%fld_name = lowercase(trim(text_names_short%mod_name))
946 text_names%fld_type =
" "
947 text_names%mod_name = lowercase(trim(record))
948 text_names%fld_name =
" "
953 list_name = list_sep//trim(text_names%mod_name)//list_sep//trim(text_names%fld_type)//&
954 list_sep//trim(text_names%fld_name)
956 index_list_name =
fm_new_list(list_name, create = .true.)
957 if ( index_list_name ==
no_field ) &
958 call mpp_error(fatal, trim(error_header)//
'Could not set field list for '//trim(list_name))
961 select case (text_names%mod_name)
973 call mpp_error(fatal, trim(error_header)//
'The model name is unrecognised : '//trim(text_names%mod_name))
976 num_fields = num_fields + 1
978 if (num_fields > max_fields)
call mpp_error(fatal,trim(error_header)//
'max fields exceeded')
979 fields(num_fields)%model = model
980 fields(num_fields)%field_name = lowercase(trim(text_names%fld_name))
981 fields(num_fields)%field_type = lowercase(trim(text_names%fld_type))
982 fields(num_fields)%num_methods = 0
983 allocate(
fields(num_fields)%methods(max_field_methods))
984 call check_for_name_duplication
987 if ( record(len_trim(record):len_trim(record)) == list_sep) cycle
991 do while (flag_method)
992 read(iunit,
'(a)',
end=99,err=99) record
994 if (len_trim(record) .le. 0) cycle
996 if ( record(len_trim(record):len_trim(record)) == list_sep)
then
997 flag_method = .false.
998 if (len_trim(record) == 1) cycle
999 record = record(:len_trim(record)-1)
1002 if (len_trim(record) .le. 0) cycle
1004 if (record(1:1) == comment ) cycle
1007 do l= 1, len_trim(record)
1008 if (record(l:l) == dquote )
then
1012 if (icount > 6 )
call mpp_error(fatal,trim(error_header)//
'Too many fields in field entry.'//trim(record))
1015 call mpp_error(fatal, trim(error_header)//
'Could not change to '//trim(list_name)//
' list')
1017 select case (icount)
1019 read(record,*,
end=99,err=99) text_method
1020 fields(num_fields)%methods(m)%method_type = lowercase(trim(text_method%method_type))
1021 fields(num_fields)%methods(m)%method_name = lowercase(trim(text_method%method_name))
1022 fields(num_fields)%methods(m)%method_control = lowercase(trim(text_method%method_control))
1024 type_str = text_method%method_type
1025 name_str = text_method%method_name
1026 control_str = text_method%method_control
1030 read(record,*,
end=99,err=99) text_method_short
1031 fields(num_fields)%methods(m)%method_type =&
1032 & lowercase(trim(text_method_short%method_type))
1033 fields(num_fields)%methods(m)%method_name =&
1034 & lowercase(trim(text_method_short%method_name))
1035 fields(num_fields)%methods(m)%method_control =
" "
1037 type_str = text_method_short%method_type
1039 control_str = text_method_short%method_name
1044 read(record,*,
end=99,err=99) text_method_very_short
1045 fields(num_fields)%methods(m)%method_type = lowercase(trim(text_method_very_short%method_type))
1046 fields(num_fields)%methods(m)%method_name =
" "
1047 fields(num_fields)%methods(m)%method_control =
" "
1051 control_str = text_method_very_short%method_type
1054 read(record,
'(A)',
end=99,err=99) control_str
1059 call mpp_error(fatal,trim(error_header)//
'Unterminated field in field entry.'//trim(record))
1071 ltrec= len_trim(control_str)
1072 control_array(:,1) = 1
1073 control_array(:,2:3) = ltrec
1076 if (control_str(l:l) == equal )
then
1078 control_array(icount,2) = l
1079 elseif (control_str(l:l) == comma )
then
1080 if (icount .eq. 0)
then
1081 call mpp_error(fatal,trim(error_header) // &
1082 ' Bad format for field entry (comma without equals sign): ''' // &
1083 trim(control_str) //
'''')
1084 elseif (icount .gt. max_fields)
then
1085 call mpp_error(fatal,trim(error_header) // &
1086 ' Too many fields in field entry: ''' // &
1087 trim(control_str) //
'''')
1089 control_array(icount,3) = l-1
1090 control_array(min(max_fields,icount+1),1) = l+1
1099 if (control_str(ltrec:ltrec) .ne. comma)
then
1100 control_array(max(1,icount),3) = ltrec
1103 if ( icount == 0 )
then
1104 method_name = type_str
1105 if (len_trim(method_name) > 0 )
then
1106 method_name = trim(method_name)//list_sep// trim(name_str)
1108 method_name = trim(name_str)
1110 val_name = control_str
1112 call new_name(list_name, method_name, val_name )
1117 startcont = control_array(l,1)
1118 midcont = control_array(l,2)
1119 endcont = control_array(l,3)
1121 method_name = trim(type_str)
1122 if (len_trim(method_name) > 0 )
then
1123 method_name = trim(method_name)//list_sep// trim(name_str)
1125 method_name = trim(name_str)
1128 if (len_trim(method_name) > 0 )
then
1129 method_name = trim(method_name)//list_sep//&
1130 trim(control_str(startcont:midcont-1))
1132 method_name = trim(control_str(startcont:midcont-1))
1134 val_name = trim(control_str(midcont+1:endcont))
1136 call new_name(list_name, method_name, val_name )
1141 fields(num_fields)%num_methods =
fields(num_fields)%num_methods + 1
1142 if (
fields(num_fields)%num_methods > max_field_methods) &
1143 call mpp_error(fatal,trim(error_header)//
'Maximum number of methods for field exceeded')
1147 flag_method = .true.
1148 do while (flag_method)
1149 read(iunit,
'(A)',
end=99,err=99) record
1150 if ( record(len_trim(record):len_trim(record)) == list_sep)
then
1151 flag_method = .false.
1159close(iunit, iostat=io_status)
1160if(io_status/=0)
call mpp_error(fatal,
'field_manager_mod: Error in closing file '//trim(tbl_name))
1163if(
present(nfields)) nfields = num_fields
1165default_method%method_type =
'none'
1166default_method%method_name =
'none'
1167default_method%method_control =
'none'
1172call mpp_error(fatal,trim(error_header)//
' Error reading field table. Record = '//trim(record))
1176subroutine check_for_name_duplication
1181 if (
fields(i)%field_type ==
fields(num_fields)%field_type .and. &
1183 fields(i)%field_name ==
fields(num_fields)%field_name )
then
1184 if (mpp_pe() .eq. mpp_root_pe())
then
1185 call mpp_error(warning,
'Error in field_manager_mod. Duplicate field name: Field type='//&
1186 trim(
fields(i)%field_type)// &
1188 ', Duplicated name='//trim(
fields(i)%field_name))
1193end subroutine check_for_name_duplication
1203subroutine new_name ( list_name, method_name_in , val_name_in)
1204character(len=*),
intent(in) :: list_name
1205character(len=*),
intent(in) :: method_name_in
1207character(len=*),
intent(inout) :: val_name_in
1210character(len=fm_string_len) :: method_name
1211character(len=fm_string_len) :: val_name
1212integer,
dimension(MAX_FIELDS) :: end_val
1213integer,
dimension(MAX_FIELDS) :: start_val
1222logical :: append_new
1224real(r8_kind) :: val_real
1228method_name = trim(method_name_in)
1235end_val(:) = len_trim(val_name_in)
1240do i = 1, len_trim(val_name_in)
1241 if ( val_name_in(i:i) == comma )
then
1242 end_val(num_elem) = i-1
1243 start_val(num_elem+1) = i+1
1244 num_elem = num_elem + 1
1249left_br = scan(method_name,
'[')
1250right_br = scan(method_name,
']')
1251if ( num_elem .eq. 1 )
then
1252 if ( left_br > 0 .and. right_br == 0 ) &
1253 call mpp_error(fatal, trim(error_header)//
"Left bracket present without right bracket in "//trim(method_name))
1254 if ( left_br== 0 .and. right_br > 0 ) &
1255 call mpp_error(fatal, trim(error_header)//
"Right bracket present without left bracket in "//trim(method_name))
1256 if ( left_br > 0 .and. right_br > 0 )
then
1257 if ( scan( method_name(left_br+1:right_br -1), set ) > 0 ) &
1258 call mpp_error(fatal, trim(error_header)//
"Using a non-numeric value for index in "//trim(method_name))
1259 read(method_name(left_br+1:right_br -1), *) index_t
1260 method_name = method_name(:left_br -1)
1264 if ( left_br > 0 .or. right_br > 0 ) &
1265 call mpp_error(fatal, &
1266 trim(error_header)//
"Using a comma delimited list with an indexed array element in "//trim(method_name))
1271 if ( i .gt. 1 .or. index_t .eq. 0 )
then
1275 val_type = string_type
1276 val_name = val_name_in(start_val(i):end_val(i))
1284 length = len_trim(val_name)
1285 if (val_name(1:1) .eq. squote)
then
1287 if (val_name(length:length) .eq. squote)
then
1288 val_name = val_name(2:length-1)//repeat(
" ",len(val_name)-length+2)
1289 val_type = string_type
1290 elseif (val_name(length:length) .eq. dquote)
then
1291 call mpp_error(fatal, trim(error_header) //
' Quotes do not match in ' // trim(val_name) // &
1292 ' for ' // trim(method_name) //
' of ' // trim(list_name))
1294 call mpp_error(fatal, trim(error_header) //
' No trailing quote in ' // trim(val_name) // &
1295 ' for ' // trim(method_name) //
' of ' // trim(list_name))
1298 elseif (val_name(1:1) .eq. dquote .or. val_name(length:length) .eq. dquote)
then
1300 call mpp_error(fatal, trim(error_header) //
' Double quotes not allowed in ' // trim(val_name) // &
1301 ' for ' // trim(method_name) //
' of ' // trim(list_name))
1303 elseif (val_name(length:length) .eq. squote)
then
1305 call mpp_error(fatal, trim(error_header) //
' No leading quote in ' // trim(val_name) // &
1306 ' for ' // trim(method_name) //
' of ' // trim(list_name))
1314 if ( scan(val_name(1:1), setnum ) > 0 )
then
1318 if ( scan(val_name, set_nonexp ) .le. 0 )
then
1320 if ( scan(val_name,
'.') > 0 .or. scan(val_name,
'e') > 0 .or. scan(val_name,
'E') > 0)
then
1321 read(val_name, *) val_real
1322 val_type = real_type
1324 read(val_name, *) val_int
1325 val_type = integer_type
1332 if ( len_trim(val_name) == 1 .or. len_trim(val_name) == 3)
then
1333 if ( val_name ==
't' .or. val_name ==
'T' .or. val_name ==
'.t.' .or. val_name ==
'.T.' )
then
1335 val_type = logical_type
1337 if ( val_name ==
'f' .or. val_name ==
'F' .or. val_name ==
'.f.' .or. val_name ==
'.F.' )
then
1339 val_type = logical_type
1342 if ( trim(lowercase(val_name)) ==
'true' .or. trim(lowercase(val_name)) ==
'.true.' )
then
1344 val_type = logical_type
1346 if ( trim(lowercase(val_name)) ==
'false' .or. trim(lowercase(val_name)) ==
'.false.' )
then
1348 val_type = logical_type
1352 select case(val_type)
1355 if (
fm_new_value( method_name, val_int, 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 ' (I) for '//trim(list_name))
1360 if (
fm_new_value( method_name, val_logic, 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 ' (L) for '//trim(list_name))
1365 if (
fm_new_value( method_name, val_real, 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 ' (R) for '//trim(list_name))
1370 if (
fm_new_value( method_name, val_name, create = .true., index = index_t, append = append_new) < 0 ) &
1371 call mpp_error(fatal, trim(error_header)//
'Could not set "' // trim(val_name) //
'" for '//trim(method_name)//&
1372 ' (S) for '//trim(list_name))
1374 call mpp_error(fatal, trim(error_header)//
'Could not find a valid type to set the '//trim(method_name)//&
1375 ' for '//trim(list_name))
1390module_is_initialized = .false.
1393 if(
allocated(
fields(j)%methods))
deallocate(
fields(j)%methods)
1404character(len=*),
intent(inout) :: name
1406name = trim(adjustl(name))
1418integer,
intent(in) :: model
1419character(len=*),
intent(in) :: field_name
1426 if (
fields(i)%model == model .and.
fields(i)%field_name == lowercase(field_name))
then
1438character(len=*),
intent(in) :: field_name
1457integer,
intent(in) :: n
1458character (len=*),
intent(out) :: fld_type
1459character (len=*),
intent(out) :: fld_name
1460integer,
intent(out) :: model
1461integer,
intent(out) :: num_methods
1463if (n < 1 .or. n > num_fields)
call mpp_error(fatal,trim(error_header)//
'Invalid field index')
1465fld_type =
fields(n)%field_type
1466fld_name =
fields(n)%field_name
1468num_methods =
fields(n)%num_methods
1478integer,
intent(in) :: n
1479integer,
intent(in) :: m
1482if (n < 1 .or. n > num_fields)
call mpp_error(fatal,trim(error_header)//
'Invalid field index')
1483if (m < 1 .or. m >
fields(n)%num_methods)
call mpp_error(fatal,trim(error_header)//
'Invalid method index')
1485 method =
fields(n)%methods(m)
1495integer,
intent(in) :: n
1498 if (n < 1 .or. n > num_fields) &
1499 call mpp_error(fatal,trim(error_header)//
'Invalid field index')
1501 if (
size(methods(:)) <
fields(n)%num_methods) &
1502 call mpp_error(fatal,trim(error_header)//
'Method array too small')
1504 methods = default_method
1513character(len=*),
intent(in) :: text
1514character(len=*),
intent(in) :: label
1515integer,
intent(out) :: values(:)
1521character(len=*),
intent(in) :: text
1522character(len=*),
intent(in) :: label
1523character(len=*),
intent(out) :: values(:)
1529character(len=*),
intent(in) :: text
1530character(len=*),
intent(in) :: label
1531integer,
intent(out) :: parse_ival
1537 if (
parse > 0) parse_ival = values(1)
1541character(len=*),
intent(in) :: text
1542character(len=*),
intent(in) :: label
1543character(len=*),
intent(out) :: parse_sval
1546character(len=len(parse_sval)) :: values(1)
1549 if (
parse > 0) parse_sval = values(1)
1566character(len=*),
intent(in) :: name
1568integer :: error, out_unit
1571if (.not.
associated(parent_p) .or. name .eq.
' ')
then
1577allocate(list_p, stat = error)
1578if (error .ne. 0)
then
1579 write (out_unit,*) trim(error_header),
'Error ', error, &
1580 ' allocating memory for list ', trim(name)
1588list_p%prev => parent_p%last_field
1589nullify(list_p%first_field)
1590nullify(list_p%last_field)
1592list_p%field_type = null_type
1595if (
allocated(list_p%i_value))
deallocate(list_p%i_value)
1596if (
allocated(list_p%l_value))
deallocate(list_p%l_value)
1597if (
allocated(list_p%r_value))
deallocate(list_p%r_value)
1598if (
allocated(list_p%s_value))
deallocate(list_p%s_value)
1601if (parent_p%length .le. 0)
then
1602 parent_p%first_field => list_p
1604 parent_p%last_field%next => list_p
1607parent_p%last_field => list_p
1609parent_p%length = parent_p%length + 1
1611list_p%index = parent_p%length
1613list_p%parent => parent_p
1627logical recursive function
dump_list(list_p,
recursive, depth, out_unit) result(success)
1630 logical,
intent(in) ::
recursive
1631 integer,
intent(in) :: depth
1633 integer,
intent(in) :: out_unit
1637 character(len=fm_field_name_len) :: num, scratch
1638 type (
field_def),
pointer :: this_field_p
1639 character(len=depth+fm_field_name_len) :: blank
1645 if (.not.
associated(list_p))
then
1647 elseif (list_p%field_type .ne. list_type)
then
1655 write (out_unit,
'(a,a,a)') blank(1:depth), trim(list_p%name), list_sep
1662 this_field_p => list_p%first_field
1664 do while (
associated(this_field_p))
1666 select case(this_field_p%field_type)
1671 success =
dump_list(this_field_p, .true., depthp1, out_unit)
1672 if (.not.success)
exit
1674 write (out_unit,
'(a,a,a)') blank(1:depthp1), trim(this_field_p%name), list_sep
1678 if (this_field_p%max_index .eq. 0)
then
1679 write (out_unit,
'(a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = NULL'
1680 elseif (this_field_p%max_index .eq. 1)
then
1681 write (scratch,*) this_field_p%i_value(1)
1682 write (out_unit,
'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = ', &
1683 trim(adjustl(scratch))
1685 do j = 1, this_field_p%max_index
1686 write (scratch,*) this_field_p%i_value(j)
1688 write (out_unit,
'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1689 '[', trim(adjustl(num)),
'] = ', trim(adjustl(scratch))
1694 if (this_field_p%max_index .eq. 0)
then
1695 write (out_unit,
'(a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = NULL'
1696 elseif (this_field_p%max_index .eq. 1)
then
1697 write (scratch,
'(l1)') this_field_p%l_value(1)
1698 write (out_unit,
'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = ', &
1699 trim(adjustl(scratch))
1701 do j = 1, this_field_p%max_index
1702 write (scratch,
'(l1)') this_field_p%l_value(j)
1704 write (out_unit,
'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1705 '[', trim(adjustl(num)),
'] = ', trim(adjustl(scratch))
1710 if (this_field_p%max_index .eq. 0)
then
1711 write (out_unit,
'(a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = NULL'
1712 elseif (this_field_p%max_index .eq. 1)
then
1713 write (scratch,*) this_field_p%r_value(1)
1714 write (out_unit,
'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = ', &
1715 trim(adjustl(scratch))
1717 do j = 1, this_field_p%max_index
1718 write (scratch,*) this_field_p%r_value(j)
1720 write (out_unit,
'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1721 '[', trim(adjustl(num)),
'] = ', trim(adjustl(scratch))
1726 if (this_field_p%max_index .eq. 0)
then
1727 write (out_unit,
'(a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = NULL'
1728 elseif (this_field_p%max_index .eq. 1)
then
1729 write (out_unit,
'(a,a,a,a)') blank(1:depthp1), trim(this_field_p%name),
' = ', &
1730 ''''//trim(this_field_p%s_value(1))//
''''
1732 do j = 1, this_field_p%max_index
1734 write (out_unit,
'(a,a,a,a,a,a)') blank(1:depthp1), trim(this_field_p%name), &
1735 '[', trim(adjustl(num)),
'] = ',
''''//trim(this_field_p%s_value(j))//
''''
1745 this_field_p => this_field_p%next
1758character(len=*),
intent(in) :: name
1759character(len=*),
intent(out) :: path
1760character(len=*),
intent(out) :: base
1767length = max(len_trim(name),0)
1768if (length .eq. 0)
then
1775 do while (name(length:length) .eq. list_sep)
1777 if (length .eq. 0)
then
1781 if (length .eq. 0)
then
1788 i = index(name(1:length), list_sep, back = .true.)
1793 base = name(1:length)
1798 base = name(i+1:length)
1816character(len=*),
intent(in) :: name
1820type (
field_def),
pointer,
save :: temp_p
1825if (name .eq.
'.')
then
1828 field_p => this_list_p
1829elseif (name .eq.
'..')
then
1831 field_p => this_list_p%parent
1834 temp_p => this_list_p%first_field
1836 do while (
associated(temp_p))
1839 if (temp_p%name .eq. name)
then
1844 temp_p => temp_p%next
1860character(len=*),
intent(in) :: name
1861character(len=*),
intent(out) :: head
1862character(len=*),
intent(out) :: rest
1866i = index(name, list_sep)
1869do while (i .le. len(name))
1870 if (name(i+1:i+1) .eq. list_sep)
then
1882elseif (i .eq. len(name))
then
1907character(len=*),
intent(in) :: path
1909logical,
intent(in) :: create
1911character(len=FMS_PATH_LEN) :: working_path
1912character(len=FMS_PATH_LEN) :: rest
1913character(len=fm_field_name_len) :: this_list
1914integer :: i, out_unit
1915type (
field_def),
pointer,
save :: working_path_p
1916type (
field_def),
pointer,
save :: this_list_p
1921if (path .eq.
' ')
then
1923 list_p => relative_p
1929 if (path(1:1) .eq. list_sep)
then
1930 working_path_p => root_p
1931 working_path = path(2:)
1933 working_path_p => relative_p
1937 do while (working_path .ne.
' ')
1939 call find_head(working_path, this_list, rest)
1942 if (this_list .eq.
' ')
then
1947 i = len_trim(this_list)
1948 do while (i .gt. 0 .and. this_list(i:i) .eq. list_sep)
1949 this_list(i:i) =
' '
1953 this_list_p =>
find_field(this_list, working_path_p)
1955 if (.not.
associated(this_list_p))
then
1958 this_list_p =>
make_list(working_path_p, this_list)
1959 if (.not.
associated(this_list_p))
then
1972 if (this_list_p%field_type .eq. list_type)
then
1973 working_path_p => this_list_p
1980 list_p => working_path_p
1995character(len=*),
intent(in) :: name
1997type (
field_def),
pointer,
save :: temp_p
1999if (.not. module_is_initialized)
then
2003temp_p =>
find_list(name, current_list_p, .false.)
2005if (
associated(temp_p))
then
2006 current_list_p => temp_p
2027character(len=*),
intent(in) :: name
2029type (
field_def),
pointer,
save :: temp_list_p
2032if (.not. module_is_initialized)
then
2037if (name .eq.
' ')
then
2042temp_list_p =>
find_list(name, current_list_p, .false.)
2044if (
associated(temp_list_p))
then
2046 if (save_root_name .ne.
' ')
then
2047 root_p%name = save_root_name
2048 root_p%parent => save_root_parent_p
2051 root_p => temp_list_p
2053 save_root_name = root_p%name
2054 save_root_parent_p => root_p%parent
2057 nullify(root_p%parent)
2060 current_list_p => root_p
2076 character(len=*),
intent(in) :: name
2077 logical,
intent(in),
optional ::
recursive
2079 integer,
intent(in),
optional :: unit
2081 logical :: recursive_t
2082 type (
field_def),
pointer,
save :: temp_list_p
2085 if (
present(unit))
then
2091 recursive_t = .false.
2092 if (
present(
recursive)) recursive_t =
recursive
2095 if (name .eq.
' ')
then
2097 temp_list_p => current_list_p
2101 temp_list_p =>
find_list(name, current_list_p, .false.)
2102 if (
associated(temp_list_p))
then
2110 success =
dump_list(temp_list_p, recursive_t, 0, out_unit)
2122character(len=*),
intent(in) :: name
2124type (
field_def),
pointer,
save :: dummy_p
2126if (.not. module_is_initialized)
then
2130dummy_p =>
get_field(name, current_list_p)
2131success =
associated(dummy_p)
2145character(len=*),
intent(in) :: name
2147type (
field_def),
pointer,
save :: temp_field_p
2152if (.not. module_is_initialized)
then
2156if (name .eq.
' ')
then
2161temp_field_p =>
get_field(name, current_list_p)
2162if (
associated(temp_field_p))
then
2164 index = temp_field_p%index
2178character(len=FMS_PATH_LEN) :: path
2180type (
field_def),
pointer,
save :: temp_list_p
2182if (.not. module_is_initialized)
then
2187temp_list_p => current_list_p
2190do while (
associated(temp_list_p))
2193 if (temp_list_p%name .eq.
' ')
then
2197 path = list_sep // trim(temp_list_p%name) // path
2199 temp_list_p => temp_list_p%parent
2202if (.not.
associated(temp_list_p))
then
2206elseif (path .eq.
' ')
then
2223character(len=*),
intent(in) :: name
2225type (
field_def),
pointer,
save :: temp_field_p
2230if (.not. module_is_initialized)
then
2234if (name .eq.
' ')
then
2239temp_field_p =>
get_field(name, current_list_p)
2241if (
associated(temp_field_p))
then
2243 if (temp_field_p%field_type .eq. list_type)
then
2244 length = temp_field_p%length
2246 length = temp_field_p%max_index
2262 result(name_field_type)
2263character(len=8) :: name_field_type
2264character(len=*),
intent(in) :: name
2266type (
field_def),
pointer,
save :: temp_field_p
2271if (.not. module_is_initialized)
then
2275if (name .eq.
' ')
then
2276 name_field_type =
' '
2280temp_field_p =>
get_field(name, current_list_p)
2282if (
associated(temp_field_p))
then
2284 name_field_type = field_type_name(temp_field_p%field_type)
2286 name_field_type =
' '
2296character(len=*),
intent(in) :: name
2297integer,
intent(out) :: get_ival
2298integer,
intent(in),
optional :: index
2301type (
field_def),
pointer,
save :: temp_field_p
2306if (.not. module_is_initialized)
then
2310if (name .eq.
' ')
then
2316if (
present(index))
then
2322temp_field_p =>
get_field(name, current_list_p)
2324if (
associated(temp_field_p))
then
2326 if (temp_field_p%field_type .eq. integer_type)
then
2327 if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index)
then
2333 get_ival = temp_field_p%i_value(index_t)
2353character(len=*),
intent(in) :: name
2354logical,
intent(out) :: get_lval
2355integer,
intent(in),
optional :: index
2358type (
field_def),
pointer,
save :: temp_field_p
2363if (.not. module_is_initialized)
then
2367if (name .eq.
' ')
then
2373if (
present(index))
then
2379temp_field_p =>
get_field(name, current_list_p)
2381if (
associated(temp_field_p))
then
2383 if (temp_field_p%field_type .eq. logical_type)
then
2385 if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index)
then
2391 get_lval = temp_field_p%l_value(index_t)
2411character(len=*),
intent(in) :: name
2412character(len=*),
intent(out) :: get_sval
2413integer,
intent(in),
optional :: index
2416type (
field_def),
pointer,
save :: temp_field_p
2421if (.not. module_is_initialized)
then
2425if (name .eq.
' ')
then
2431if (
present(index))
then
2437temp_field_p =>
get_field(name, current_list_p)
2439if (
associated(temp_field_p))
then
2441 if (temp_field_p%field_type .eq. string_type)
then
2442 if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index)
then
2448 get_sval = temp_field_p%s_value(index_t)
2469character(len=*),
intent(in) :: list
2470character(len=*),
intent(out) :: name
2471character(len=fm_type_name_len),
intent(out) :: field_type
2472integer,
intent(out) :: index
2478if (.not. module_is_initialized)
then
2482if (list .eq. loop_list .and.
associated(loop_list_p))
then
2484 loop_list_p => loop_list_p%next
2486elseif (list .eq.
' ')
then
2489 loop_list_p => current_list_p%first_field
2494 loop_list_p =>
find_list(loop_list, current_list_p, .false.)
2495 if (
associated(loop_list_p))
then
2496 loop_list_p => loop_list_p%first_field
2516 if (
associated(loop_list_p))
then
2517 name = loop_list_p%name
2518 field_type = field_type_name(loop_list_p%field_type)
2519 index = loop_list_p%index
2536 character(len=*) ,
intent(in) :: loop_list
2541 if (loop_list==
' ')
then
2542 iter%ptr => current_list_p%first_field
2544 iter%ptr =>
find_list(loop_list,current_list_p,.false.)
2545 if (
associated(iter%ptr)) iter%ptr => iter%ptr%first_field
2553 result(success) ;
logical success
2555 character(len=*),
intent(out) :: name
2556 character(len=*),
intent(out) :: field_type
2557 integer ,
intent(out) :: index
2560 if (
associated(iter%ptr))
then
2561 name = iter%ptr%name
2562 field_type = field_type_name(iter%ptr%field_type)
2563 index = iter%ptr%index
2565 iter%ptr => iter%ptr%next
2582character(len=*),
intent(in) :: name
2583logical,
intent(in),
optional :: create
2584logical,
intent(in),
optional :: keep
2588character(len=FMS_PATH_LEN) :: path
2589character(len=fm_field_name_len) :: base
2590type (
field_def),
pointer,
save :: temp_list_p
2595if (.not. module_is_initialized)
then
2599if (name .eq.
' ')
then
2604if (
present(create))
then
2610if (
present(keep))
then
2618temp_list_p =>
find_list(path, current_list_p, create_t)
2620if (
associated(temp_list_p))
then
2622 temp_list_p =>
make_list(temp_list_p, base)
2623 if (
associated(temp_list_p))
then
2626 current_list_p => temp_list_p
2628 index = temp_list_p%index
2642integer :: field_index
2643character(len=*),
intent(in) :: name
2645integer,
intent(in) :: new_ival
2647logical,
intent(in),
optional :: create
2649integer,
intent(in),
optional :: index
2651logical,
intent(in),
optional :: append
2657integer,
pointer,
dimension(:) :: temp_i_value
2658character(len=FMS_PATH_LEN) :: path
2659character(len=fm_field_name_len) :: base
2660type (
field_def),
pointer,
save :: temp_list_p
2661type (
field_def),
pointer,
save :: temp_field_p
2666if (.not. module_is_initialized)
then
2670if (name .eq.
' ')
then
2675if (
present(create))
then
2681if (
present(index) .and.
present(append))
then
2682 if (append .and. index .gt. 0)
then
2688if (
present(index))
then
2690 if (index_t .lt. 0)
then
2700temp_list_p =>
find_list(path, current_list_p, create_t)
2702if (
associated(temp_list_p))
then
2703 temp_field_p =>
find_field(base, temp_list_p)
2704 if (.not.
associated(temp_field_p))
then
2708 if (
associated(temp_field_p))
then
2711 if (temp_field_p%field_type == real_type )
then
2714 field_index =
fm_new_value(name, real(new_ival,r8_kind), create, index, append)
2716 else if (temp_field_p%field_type /= integer_type )
then
2719 temp_field_p%max_index = 0
2722 temp_field_p%field_type = integer_type
2724 if (
present(append))
then
2726 index_t = temp_field_p%max_index + 1
2730 if (index_t .gt. temp_field_p%max_index + 1)
then
2735 elseif (index_t .eq. 0 .and. &
2736 temp_field_p%max_index .gt. 0)
then
2741 elseif (.not.
allocated(temp_field_p%i_value) .and. &
2742 index_t .gt. 0)
then
2744 allocate(temp_field_p%i_value(1))
2745 temp_field_p%max_index = 1
2746 temp_field_p%array_dim = 1
2747 elseif (index_t .gt. temp_field_p%array_dim)
then
2750 temp_field_p%array_dim = temp_field_p%array_dim + array_increment
2751 allocate (temp_i_value(temp_field_p%array_dim))
2752 do i = 1, temp_field_p%max_index
2753 temp_i_value(i) = temp_field_p%i_value(i)
2755 if (
allocated(temp_field_p%i_value))
deallocate(temp_field_p%i_value)
2756 temp_field_p%i_value = temp_i_value
2757 temp_field_p%max_index = index_t
2761 if (index_t .gt. 0)
then
2762 temp_field_p%i_value(index_t) = new_ival
2763 if (index_t .gt. temp_field_p%max_index)
then
2764 temp_field_p%max_index = index_t
2767 field_index = temp_field_p%index
2782integer :: field_index
2783character(len=*),
intent(in) :: name
2785logical,
intent(in) :: new_lval
2787logical,
intent(in),
optional :: create
2789integer,
intent(in),
optional :: index
2791logical,
intent(in),
optional :: append
2794character(len=FMS_PATH_LEN) :: path
2795character(len=fm_field_name_len) :: base
2799logical,
dimension(:),
pointer :: temp_l_value
2800type (
field_def),
pointer,
save :: temp_list_p
2801type (
field_def),
pointer,
save :: temp_field_p
2806if (.not. module_is_initialized)
then
2810if (name .eq.
' ')
then
2815if (
present(create))
then
2821if (
present(index) .and.
present(append))
then
2822 if (append .and. index .gt. 0)
then
2828if (
present(index))
then
2830 if (index_t .lt. 0)
then
2840temp_list_p =>
find_list(path, current_list_p, create_t)
2842if (
associated(temp_list_p))
then
2843 temp_field_p =>
find_field(base, temp_list_p)
2844 if (.not.
associated(temp_field_p))
then
2848 if (
associated(temp_field_p))
then
2851 if (temp_field_p%field_type /= logical_type )
then
2852 temp_field_p%max_index = 0
2855 temp_field_p%field_type = logical_type
2857 if (
present(append))
then
2859 index_t = temp_field_p%max_index + 1
2863 if (index_t .gt. temp_field_p%max_index + 1)
then
2868 elseif (index_t .eq. 0 .and. &
2869 temp_field_p%max_index .gt. 0)
then
2874 elseif (.not.
allocated(temp_field_p%l_value) .and. &
2875 index_t .gt. 0)
then
2877 allocate(temp_field_p%l_value(1))
2878 temp_field_p%max_index = 1
2879 temp_field_p%array_dim = 1
2881 elseif (index_t .gt. temp_field_p%array_dim)
then
2884 temp_field_p%array_dim = temp_field_p%array_dim + array_increment
2885 allocate (temp_l_value(temp_field_p%array_dim))
2886 do i = 1, temp_field_p%max_index
2887 temp_l_value(i) = temp_field_p%l_value(i)
2889 if (
allocated(temp_field_p%l_value))
deallocate(temp_field_p%l_value)
2890 temp_field_p%l_value = temp_l_value
2891 temp_field_p%max_index = index_t
2896 if (index_t .gt. 0)
then
2897 temp_field_p%l_value(index_t) = new_lval
2898 if (index_t .gt. temp_field_p%max_index)
then
2899 temp_field_p%max_index = index_t
2902 field_index = temp_field_p%index
2916integer :: field_index
2917character(len=*),
intent(in) :: name
2919character(len=*),
intent(in) :: new_sval
2921logical,
intent(in),
optional :: create
2923integer,
intent(in),
optional :: index
2925logical,
intent(in),
optional :: append
2927character(len=fm_string_len),
dimension(:),
pointer :: temp_s_value
2928character(len=FMS_PATH_LEN) :: path
2929character(len=fm_field_name_len) :: base
2933type (
field_def),
save,
pointer :: temp_list_p
2934type (
field_def),
save,
pointer :: temp_field_p
2939if (.not. module_is_initialized)
then
2943if (name .eq.
' ')
then
2948if (
present(create))
then
2954if (
present(index) .and.
present(append))
then
2955 if (append .and. index .gt. 0)
then
2961if (
present(index))
then
2963 if (index_t .lt. 0)
then
2973temp_list_p =>
find_list(path, current_list_p, create_t)
2975if (
associated(temp_list_p))
then
2976 temp_field_p =>
find_field(base, temp_list_p)
2977 if (.not.
associated(temp_field_p))
then
2981 if (
associated(temp_field_p))
then
2984 if (temp_field_p%field_type /= string_type )
then
2985 temp_field_p%max_index = 0
2988 temp_field_p%field_type = string_type
2990 if (
present(append))
then
2992 index_t = temp_field_p%max_index + 1
2996 if (index_t .gt. temp_field_p%max_index + 1)
then
3001 elseif (index_t .eq. 0 .and. &
3002 temp_field_p%max_index .gt. 0)
then
3007 elseif (.not.
allocated(temp_field_p%s_value) .and. &
3008 index_t .gt. 0)
then
3010 allocate(temp_field_p%s_value(1))
3011 temp_field_p%max_index = 1
3012 temp_field_p%array_dim = 1
3014 elseif (index_t .gt. temp_field_p%array_dim)
then
3017 temp_field_p%array_dim = temp_field_p%array_dim + array_increment
3018 allocate (temp_s_value(temp_field_p%array_dim))
3019 do i = 1, temp_field_p%max_index
3020 temp_s_value(i) = temp_field_p%s_value(i)
3022 if (
allocated(temp_field_p%s_value))
deallocate(temp_field_p%s_value)
3023 temp_field_p%s_value = temp_s_value
3024 temp_field_p%max_index = index_t
3029 if (index_t .gt. 0)
then
3030 temp_field_p%s_value(index_t) = new_sval
3031 if (index_t .gt. temp_field_p%max_index)
then
3032 temp_field_p%max_index = index_t
3035 field_index = temp_field_p%index
3051if (.not. module_is_initialized)
then
3068if (.not. module_is_initialized)
then
3072root_p%name = save_root_name
3073root_p%parent => save_root_parent_p
3078nullify(save_root_parent_p)
3088character(len=*),
intent(in) :: name
3092character(len=FMS_PATH_LEN) :: path
3093character(len=fm_field_name_len) :: base
3094type (
field_def),
pointer,
save :: temp_p
3100if (path .ne.
' ')
then
3101 temp_p =>
find_list(path, this_list_p, .false.)
3102 if (
associated(temp_p))
then
3123character(len=*),
intent(in) :: oldname
3125character(len=*),
intent(in) :: newname
3128character(len=FMS_PATH_LEN) :: path
3129character(len=fm_field_name_len) :: base
3130type (
field_def),
pointer,
save :: list_p
3131type (
field_def),
pointer,
save :: temp_p
3136if (path .ne.
' ')
then
3137 temp_p =>
find_list(path, current_list_p, .false.)
3138 if (
associated(temp_p))
then
3140 if (
associated(list_p))
then
3141 list_p%name = newname
3149 if (
associated(list_p))
then
3150 list_p%name = newname
3164 if (.not. module_is_initialized)
then
3166 read (input_nml_file, nml=field_manager_nml, iostat=io)
3167 ierr = check_nml_error(io,
"field_manager_nml")
3170 if (mpp_pe() == mpp_root_pe())
write (logunit, nml=field_manager_nml)
3174 field_type_name(integer_type) =
'integer'
3175 field_type_name(list_type) =
'list'
3176 field_type_name(logical_type) =
'logical'
3177 field_type_name(real_type) =
'real'
3178 field_type_name(string_type) =
'string'
3182 root%parent => root_p
3184 root%field_type = list_type
3187 nullify(root%first_field)
3188 nullify(root%last_field)
3191 if (
allocated(root%i_value))
deallocate(root%i_value)
3192 if (
allocated(root%l_value))
deallocate(root%l_value)
3193 if (
allocated(root%r_value))
deallocate(root%r_value)
3194 if (
allocated(root%s_value))
deallocate(root%s_value)
3199 current_list_p => root
3201 nullify(loop_list_p)
3204 nullify(save_root_parent_p)
3205 save_root_name =
' '
3207 module_is_initialized = .true.
3222character(len=*),
intent(in) :: name
3224type (
field_def),
pointer,
save :: dummy_p
3232if (
associated(dummy_p))
then
3240if (.not.
associated(list_p))
then
3246list_p%field_type = list_type
3247if (
allocated(list_p%i_value))
deallocate(list_p%i_value)
3248if (
allocated(list_p%l_value))
deallocate(list_p%l_value)
3249if (
allocated(list_p%r_value))
deallocate(list_p%r_value)
3250if (
allocated(list_p%s_value))
deallocate(list_p%s_value)
3265character(len=*),
intent(in) :: name
3266character(len=*),
intent(out) :: method_name
3267character(len=*),
intent(out) :: method_control
3269character(len=FMS_PATH_LEN) :: path
3270character(len=FMS_PATH_LEN) :: base
3271character(len=FMS_PATH_LEN) :: name_loc
3272logical :: recursive_t
3273type (
field_def),
pointer,
save :: temp_list_p
3274type (
field_def),
pointer,
save :: temp_value_p
3275type (
field_def),
pointer,
save :: this_field_p
3280 recursive_t = .true.
3282 method_control =
" "
3285name_loc = lowercase(name)
3288 temp_list_p =>
find_list(name_loc, current_list_p, .false.)
3290if (
associated(temp_list_p))
then
3292 success =
query_method(temp_list_p, recursive_t, base, method_name, method_control)
3297 temp_value_p =>
find_list(path, current_list_p, .false.)
3298 if (
associated(temp_value_p))
then
3300 this_field_p => temp_value_p%first_field
3302 do while (
associated(this_field_p))
3303 if ( this_field_p%name == base )
then
3304 method_name = this_field_p%s_value(1)
3311 this_field_p => this_field_p%next
3326recursive function query_method(list_p, recursive, name, method_name, method_control) &
3330logical,
intent(in) ::
recursive
3331character(len=*),
intent(in) :: name
3332character(len=*),
intent(out) :: method_name
3333character(len=*),
intent(out) :: method_control
3336character(len=64) :: scratch
3337type (
field_def),
pointer :: this_field_p
3343if (.not.
associated(list_p) .or. list_p%field_type .ne. list_type)
then
3350 this_field_p => list_p%first_field
3352 do while (
associated(this_field_p))
3353 select case(this_field_p%field_type)
3357 if (.not.
query_method(this_field_p, .true., this_field_p%name, method_name, method_control))
then
3361 method_name = trim(method_name)//trim(this_field_p%name)
3366 write (scratch,*) this_field_p%i_value
3367 call concat_strings(method_control, comma//trim(this_field_p%name)//
' = '//trim(adjustl(scratch)))
3370 write (scratch,
'(l1)')this_field_p%l_value
3371 call concat_strings(method_control, comma//trim(this_field_p%name)//
' = '//trim(adjustl(scratch)))
3374 write (scratch,*) this_field_p%r_value
3375 call concat_strings(method_control, comma//trim(this_field_p%name)//
' = '//trim(adjustl(scratch)))
3378 call concat_strings(method_control, comma//trim(this_field_p%name)//
' = '//trim(this_field_p%s_value(1)))
3379 do i = 2, this_field_p%max_index
3380 call concat_strings(method_control, comma//trim(this_field_p%s_value(i)))
3388 this_field_p => this_field_p%next
3396 character(*),
intent(inout) :: str1
3397 character(*),
intent(in) :: str2
3399 character(64) :: n1,n2
3401 if (len_trim(str1)+len_trim(str2)>len(str1))
then
3402 write(n1,*)len(str1)
3403 write(n2,*)len_trim(str1)+len_trim(str2)
3404 call mpp_error(fatal,
'length of output string ('//trim(adjustl(n1))&
3405 //
') is not enough for the result of concatenation (len='&
3406 //trim(adjustl(n2))//
')')
3408 str1 = trim(str1)//trim(str2)
3421character(len=*),
intent(in) :: list_name
3422character(len=*),
intent(in) :: suffix
3424logical,
intent(in),
optional :: create
3426character(len=fm_string_len),
dimension(:),
allocatable :: control
3427character(len=fm_string_len),
dimension(:),
allocatable :: method
3428character(len=fm_string_len) :: head
3429character(len=fm_string_len) :: list_name_new
3430character(len=fm_string_len) :: tail
3431character(len=fm_string_len) :: val_str
3435logical :: found_methods
3437logical :: recursive_t
3439logical :: val_logical
3440real(r8_kind) :: val_real
3441type (
field_def),
pointer,
save :: temp_field_p
3442type (
field_def),
pointer,
save :: temp_list_p
3449list_name_new = trim(list_name)//trim(suffix)
3450 recursive_t = .true.
3452if (.not. module_is_initialized)
then
3456if (list_name .eq.
' ')
then
3458 temp_list_p => current_list_p
3462 temp_list_p =>
find_list(list_name, current_list_p, .false.)
3463 if (
associated(temp_list_p))
then
3473 do n = 1,
size(method)
3474 if (len_trim(method(n)) > 0 )
then
3475 index =
fm_new_list(trim(list_name_new)//list_sep//method(n), create = create)
3477 temp_field_p =>
find_list(trim(list_name)//list_sep//head,temp_list_p, .false.)
3478 temp_field_p =>
find_field(tail,temp_field_p)
3479 select case (temp_field_p%field_type)
3481 got_value =
fm_get_value( trim(list_name)//list_sep//method(n), val_int)
3482 if (
fm_new_value( trim(list_name_new)//list_sep//method(n), val_int, &
3483 create = create, append = .true.) < 0 ) &
3484 call mpp_error(fatal, trim(error_header)//
'Could not set the '//trim(method(n))//&
3485 ' for '//trim(list_name)//trim(suffix))
3488 got_value =
fm_get_value( trim(list_name)//list_sep//method(n), val_logical)
3489 if (
fm_new_value( trim(list_name_new)//list_sep//method(n), val_logical, &
3490 create = create, append = .true.) < 0 ) &
3491 call mpp_error(fatal, trim(error_header)//
'Could not set the '//trim(method(n))//&
3492 ' for '//trim(list_name)//trim(suffix))
3495 got_value =
fm_get_value( trim(list_name)//list_sep//method(n), val_real)
3496 if (
fm_new_value( trim(list_name_new)//list_sep//method(n), val_real, &
3497 create = create, append = .true.) < 0 ) &
3498 call mpp_error(fatal, trim(error_header)//
'Could not set the '//trim(method(n))//&
3499 ' for '//trim(list_name)//trim(suffix))
3502 got_value =
fm_get_value( trim(list_name)//list_sep//method(n), val_str)
3503 if (
fm_new_value( trim(list_name_new)//list_sep//method(n), val_str, &
3504 create = create, append = .true.) < 0 ) &
3505 call mpp_error(fatal, trim(error_header)//
'Could not set the '//trim(method(n))//&
3506 ' for '//trim(list_name)//trim(suffix))
3525character(len=*),
intent(in) :: list_name
3526character(len=*),
intent(out),
dimension(:) :: methods
3527character(len=*),
intent(out),
dimension(:) :: control
3530logical :: recursive_t
3531type (
field_def),
pointer,
save :: temp_list_p
3537 recursive_t = .true.
3539if (.not. module_is_initialized)
then
3543if (list_name .eq.
' ')
then
3545 temp_list_p => current_list_p
3549 temp_list_p =>
find_list(list_name, current_list_p, .false.)
3550 if (
associated(temp_list_p))
then
3559 success =
find_method(temp_list_p, recursive_t, num_meth, methods, control)
3568recursive function find_method(list_p, recursive, num_meth, method, control) &
3572logical,
intent(in) ::
recursive
3573integer,
intent(inout) :: num_meth
3574character(len=*),
intent(out),
dimension(:) :: method
3575character(len=*),
intent(out),
dimension(:) :: control
3577character(len=FMS_PATH_LEN) :: scratch
3580type (
field_def),
pointer,
save :: this_field_p
3585if (.not.
associated(list_p) .or. list_p%field_type .ne. list_type)
then
3591 this_field_p => list_p%first_field
3593 do while (
associated(this_field_p))
3594 select case(this_field_p%field_type)
3597 if ( this_field_p%length > 1)
then
3598 do n = num_meth+1, num_meth + this_field_p%length - 1
3599 write (method(n),
'(a,a,a,$)') trim(method(num_meth)), &
3600 trim(this_field_p%name), list_sep
3602 write (method(num_meth),
'(a,a,a,$)') trim(method(num_meth)), &
3603 trim(this_field_p%name), list_sep
3605 write (method(num_meth),
'(a,a,a,$)') trim(method(num_meth)), &
3606 trim(this_field_p%name), list_sep
3608 success =
find_method(this_field_p, .true., num_meth, method, control)
3611 write (scratch,*) this_field_p%i_value
3613 write (method(num_meth),
'(a,a)') trim(method(num_meth)), &
3614 trim(this_field_p%name)
3615 write (control(num_meth),
'(a)') &
3617 num_meth = num_meth + 1
3622 write (method(num_meth),
'(a,a)') trim(method(num_meth)), &
3623 trim(this_field_p%name)
3624 write (control(num_meth),
'(l1)') &
3625 this_field_p%l_value
3626 num_meth = num_meth + 1
3630 if(
allocated(this_field_p%r_value))
write (scratch,*) this_field_p%r_value
3632 write (method(num_meth),
'(a,a)') trim(method(num_meth)), &
3633 trim(this_field_p%name)
3634 write (control(num_meth),
'(a)') &
3636 num_meth = num_meth + 1
3640 write (method(num_meth),
'(a,a)') trim(method(num_meth)), &
3641 trim(this_field_p%name)
3642 write (control(num_meth),
'(a)') &
3643 trim(this_field_p%s_value(1))
3644 do i = 2, this_field_p%max_index
3645 write (control(num_meth),
'(a,a,$)') comma//trim(this_field_p%s_value(i))
3647 num_meth = num_meth + 1
3656 this_field_p => this_field_p%next
3662#include "field_manager_r4.fh"
3663#include "field_manager_r8.fh"
3665end module field_manager_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.
logical function set_list_stuff()
If the the pointer matches to the right list, extract the field information. Used in fm_loop_over_lis...
subroutine, public get_field_info(n, fld_type, fld_name, model, num_methods)
This routine allows access to field information given an index.
subroutine concat_strings(str1, str2)
private function: appends str2 to the end of str1, with length check
character(len=8) function, public fm_get_type(name)
A function to return the type of the named field.
subroutine, private find_head(name, head, rest)
Find the first list for a name by splitting the name into a head and the rest.
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 get_field_method(n, m, method)
A routine to get a specified method.
logical function fm_loop_over_list_old(list, name, field_type, index)
Iterates through the given list.
integer, parameter, public fm_string_len
The length of a character string representing character values for the field.
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...
subroutine read_field_table_legacy(nfields, table_name)
Routine to read and parse the field table yaml.
logical function, public fm_dump_list(name, recursive, unit)
A function to list properties associated with a field.
subroutine new_name_yaml(list_name, method_name_in, val_name_in)
Subroutine to add new values to list parameters.
subroutine, public fm_return_root
Return the root list to the value at initialization.
logical function, public fm_modify_name(oldname, newname)
This function allows a user to rename a field without modifying the contents of the field.
integer, parameter, public model_land
Land model.
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.
function parse_strings(text, label, values)
function parse_integers(text, label, values)
integer function parse_string(text, label, parse_sval)
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...
logical function, public fm_change_root(name)
Change the root list.
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...
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.
type(field_mgr_type), dimension(:), allocatable, private fields
fields of field_mgr_type
subroutine, private initialize_module_variables
A function to initialize the values of the pointers. This will remove all fields and reset the field ...
subroutine, public fm_reset_loop
Resets the loop variable. For use in conjunction with fm_loop_over_list.
integer function fm_new_value_logical(name, new_lval, create, index, append)
Assigns a given value to a given field.
integer function find_field_index_new(field_name)
subroutine, public field_manager_end
Destructor for field manager.
integer function fm_new_value_integer(name, new_ival, create, index, append)
Assigns a given value to a given field.
subroutine new_name(list_name, method_name_in, val_name_in)
Subroutine to add new values to list parameters.
integer, parameter, public model_coupler
Ice model.
subroutine, private find_base(name, path, base)
A subroutine that splits a listname into a path and a base.
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.
integer function fm_new_value_string(name, new_sval, create, index, append)
Assigns a given value to a given field.
integer, parameter, public fm_field_name_len
The length of a character string representing the field name.
logical recursive function, private dump_list(list_p, recursive, depth, out_unit)
This is a function that lists the parameters of a field.
subroutine read_field_table_yaml(nfields, table_name)
Routine to read and parse the field table yaml.
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, public get_field_methods(n, methods)
A routine to obtain all the methods associated with a field.
integer, parameter, public model_ocean
Ocean model.
integer, parameter, public fm_path_name_len
The length of a character string representing the field path.
integer function, public fm_new_list(name, create, keep)
A function to create a new list.
integer, parameter, public no_field
The value returned if a field is not defined.
logical function fm_get_value_integer(name, get_ival, index)
integer, parameter, public model_ice
Ice model.
logical function, public fm_find_methods(list_name, methods, control)
This function retrieves all the methods associated with a field.
integer function find_field_index_old(model, field_name)
Function to return the index of the field.
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...
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.
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.
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.
logical function, public fm_exists(name)
A function to test whether a named field exists.
logical function fm_get_value_string(name, get_sval, index)
integer function parse_integer(text, label, parse_ival)
integer, parameter, public model_atmos
Atmospheric model.
logical function fm_get_value_logical(name, get_lval, index)
integer, parameter, public num_models
Number of models (ATMOS, OCEAN, LAND, ICE, COUPLER).
subroutine, public field_manager_init(nfields, table_name)
Routine to initialize the field manager.
subroutine strip_front_blanks(name)
A routine to strip whitespace from the start of character strings.
integer function, public fm_get_length(name)
A function to return how many elements are contained within the named list or entry.
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...
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.