FMS 2025.01-dev
Flexible Modeling System
Loading...
Searching...
No Matches
fm_util.inc
1!***********************************************************************
2!* GNU Lesser General Public License
3!*
4!* This file is part of the GFDL Flexible Modeling System (FMS).
5!*
6!* FMS is free software: you can redistribute it and/or modify it under
7!* the terms of the GNU Lesser General Public License as published by
8!* the Free Software Foundation, either version 3 of the License, or (at
9!* your option) any later version.
10!*
11!* FMS is distributed in the hope that it will be useful, but WITHOUT
12!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
14!* for more details.
15!*
16!* You should have received a copy of the GNU Lesser General Public
17!* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
18!***********************************************************************
19!> @defgroup fm_util_mod fm_util_mod
20!> @ingroup field_manager
21!> @brief This module provides utility routines for the field manager.
22!!
23!#######################################################################
24
25!> Set a real array in the Field Manager tree.
26subroutine fm_util_set_value_real_array_(name, rval, length, caller, no_overwrite, good_name_list) !{
27
28implicit none
29
30!
31! arguments
32!
33
34character(len=*), intent(in) :: name
35integer, intent(in) :: length
36real(FMS_FM_KIND_), intent(in) :: rval(length)
37character(len=*), intent(in), optional :: caller
38logical, intent(in), optional :: no_overwrite
39character(len=FMS_PATH_LEN), intent(in), optional :: good_name_list
40
41!
42! Local parameters
43!
44
45character(len=48), parameter :: sub_name = 'fm_util_set_value_real_array'
46
47!
48! Local variables
49!
50
51character(len=256) :: error_header
52character(len=256) :: warn_header
53character(len=256) :: note_header
54character(len=128) :: caller_str
55character(len=32) :: str_error
56integer :: field_index
57integer :: field_length
58integer :: n
59logical :: no_overwrite_use
60character(len=FMS_PATH_LEN) :: good_name_list_use
61logical :: add_name
62
63integer, parameter :: lkind=fms_fm_kind_
64
65!
66! set the caller string and headers
67!
68
69if (present(caller)) then !{
70 caller_str = '[' // trim(caller) // ']'
71else !}{
72 caller_str = fm_util_default_caller
73endif !}
74
75error_header = '==>Error from ' // trim(mod_name) // &
76 '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
77warn_header = '==>Warning from ' // trim(mod_name) // &
78 '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
79note_header = '==>Note from ' // trim(mod_name) // &
80 '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
81
82!
83! check that a name is given (fatal if not)
84!
85
86if (name .eq. ' ') then !{
87 call mpp_error(fatal, trim(error_header) // ' Empty name given')
88endif !}
89
90!
91! check that the length is non-negative
92!
93
94if (length .lt. 0) then !{
95 call mpp_error(fatal, trim(error_header) // ' Negative array length')
96endif !}
97
98!
99! check for whether to overwrite existing values
100!
101
102if (present(no_overwrite)) then !{
103 no_overwrite_use = no_overwrite
104else !}{
105 no_overwrite_use = default_no_overwrite
106endif !}
107
108!
109! check for whether to save the name in a list
110!
111
112if (present(good_name_list)) then !{
113 good_name_list_use = good_name_list
114else !}{
115 good_name_list_use = default_good_name_list
116endif !}
117
118!
119! write the data array
120!
121
122if (length .eq. 0) then !{
123 if (.not. (no_overwrite_use .and. fm_exists(name))) then !{
124 field_index = fm_new_value(name, 0.0_lkind, index = 0)
125 if (field_index .le. 0) then !{
126 write (str_error,*) ' with length = ', length
127 call mpp_error(fatal, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
128 endif !}
129 endif !}
130else !}{
131 if (no_overwrite_use .and. fm_exists(name)) then !{
132 field_length = fm_get_length(name)
133 if (field_length .lt. 0) then !{
134 call mpp_error(fatal, trim(error_header) // ' Problem getting length of ' // trim(name))
135 endif !}
136 do n = field_length + 1, length !{
137 field_index = fm_new_value(name, rval(n), index = n)
138 if (field_index .le. 0) then !{
139 write (str_error,*) ' with index = ', n
140 call mpp_error(fatal, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
141 endif !}
142 enddo !} n
143 else !}{
144 field_index = fm_new_value(name, rval(1))
145 if (field_index .le. 0) then !{
146 call mpp_error(fatal, trim(error_header) // ' Problem setting ' // trim(name))
147 endif !}
148 do n = 2, length !{
149 field_index = fm_new_value(name, rval(n), index = n)
150 if (field_index .le. 0) then !{
151 write (str_error,*) ' with index = ', n
152 call mpp_error(fatal, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
153 endif !}
154 enddo !} n
155 endif !}
156endif !}
157
158!
159! Add the variable name to the list of good names, to be used
160! later for a consistency check
161!
162
163if (good_name_list_use .ne. ' ') then !{
164 if (fm_exists(good_name_list_use)) then !{
165 add_name = fm_util_get_index_string(good_name_list_use, name, &
166 caller = caller_str) .le. 0 ! true if name does not exist in string array
167 else !}{
168 add_name = .true. ! always add to new list
169 endif !}
170 if (add_name .and. fm_exists(name)) then !{
171 if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then !{
172 call mpp_error(fatal, trim(error_header) // &
173 ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
174 endif !}
175 endif !}
176endif !}
177
178return
179
180end subroutine fm_util_set_value_real_array_ !}
181
182!#######################################################################
183
184!> Set a real value in the Field Manager tree.
185subroutine fm_util_set_value_real_(name, rval, caller, index, append, no_create, &
186 no_overwrite, good_name_list) !{
187
188implicit none
189
190!
191! arguments
192!
193
194character(len=*), intent(in) :: name
195real(FMS_FM_KIND_), intent(in) :: rval
196character(len=*), intent(in), optional :: caller
197integer, intent(in), optional :: index
198logical, intent(in), optional :: append
199logical, intent(in), optional :: no_create
200logical, intent(in), optional :: no_overwrite
201character(len=*), intent(in), optional :: good_name_list
202
203!
204! Local parameters
205!
206
207character(len=48), parameter :: sub_name = 'fm_util_set_value_real'
208
209!
210! Local variables
211!
212
213character(len=256) :: error_header
214character(len=256) :: warn_header
215character(len=256) :: note_header
216character(len=128) :: caller_str
217character(len=32) :: str_error
218integer :: field_index
219logical :: no_overwrite_use
220integer :: field_length
221character(len=FMS_PATH_LEN) :: good_name_list_use
222logical :: create
223logical :: add_name
224
225!
226! set the caller string and headers
227!
228
229if (present(caller)) then !{
230 caller_str = '[' // trim(caller) // ']'
231else !}{
232 caller_str = fm_util_default_caller
233endif !}
234
235error_header = '==>Error from ' // trim(mod_name) // &
236 '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
237warn_header = '==>Warning from ' // trim(mod_name) // &
238 '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
239note_header = '==>Note from ' // trim(mod_name) // &
240 '(' // trim(sub_name) // ')' // trim(caller_str) // ':'
241
242!
243! check that a name is given (fatal if not)
244!
245
246if (name .eq. ' ') then !{
247 call mpp_error(fatal, trim(error_header) // ' Empty name given')
248endif !}
249
250!
251! check that append and index are not both given
252!
253
254if (present(index) .and. present(append)) then !{
255 call mpp_error(fatal, trim(error_header) // ' Append and index both given as arguments')
256endif !}
257
258!
259! check for whether to overwrite existing values
260!
261
262if (present(no_overwrite)) then !{
263 no_overwrite_use = no_overwrite
264else !}{
265 no_overwrite_use = default_no_overwrite
266endif !}
267
268!
269! check for whether to save the name in a list
270!
271
272if (present(good_name_list)) then !{
273 good_name_list_use = good_name_list
274else !}{
275 good_name_list_use = default_good_name_list
276endif !}
277
278if (present(no_create)) then !{
279 create = .not. no_create
280 if (no_create .and. (present(append) .or. present(index))) then !{
281 call mpp_error(fatal, trim(error_header) // &
282 & ' append or index are present when no_create is true for ' // trim(name))
283 endif !}
284else !}{
285 create = .true.
286endif !}
287
288if (present(index)) then !{
289 if (fm_exists(name)) then !{
290 field_length = fm_get_length(name)
291 if (field_length .lt. 0) then !{
292 call mpp_error(fatal, trim(error_header) // ' Problem getting length of ' // trim(name))
293 endif !}
294 if (.not. (no_overwrite_use .and. field_length .ge. index)) then !{
295 field_index = fm_new_value(name, rval, index = index)
296 if (field_index .le. 0) then !{
297 write (str_error,*) ' with index = ', index
298 call mpp_error(fatal, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error))
299 endif !}
300 endif !}
301 else !}{
302 field_index = fm_new_value(name, rval, index = index)
303 if (field_index .le. 0) then !{
304 write (str_error,*) ' with index = ', index
305 call mpp_error(fatal, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
306 endif !}
307 endif !}
308elseif (present(append)) then !}{
309 field_index = fm_new_value(name, rval, append = append)
310 if (field_index .le. 0) then !{
311 write (str_error,*) ' with append = ', append
312 call mpp_error(fatal, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error))
313 endif !}
314else !}{
315 if (fm_exists(name)) then !{
316 if (.not. no_overwrite_use) then !{
317 field_index = fm_new_value(name, rval)
318 if (field_index .le. 0) then !{
319 call mpp_error(fatal, trim(error_header) // ' Problem overwriting ' // trim(name))
320 endif !}
321 endif !}
322 elseif (create) then !}{
323 field_index = fm_new_value(name, rval)
324 if (field_index .le. 0) then !{
325 call mpp_error(fatal, trim(error_header) // ' Problem creating ' // trim(name))
326 endif !}
327 endif !}
328endif !}
329
330!
331! Add the variable name to the list of good names, to be used
332! later for a consistency check, unless the field did not exist and we did not create it
333!
334
335if (good_name_list_use .ne. ' ') then !{
336 if (fm_exists(good_name_list_use)) then !{
337 add_name = fm_util_get_index_string(good_name_list_use, name, &
338 caller = caller_str) .le. 0 ! true if name does not exist in string array
339 else !}{
340 add_name = .true. ! always add to new list
341 endif !}
342 if (add_name .and. fm_exists(name)) then !{
343 if (fm_new_value(good_name_list_use, name, append = .true., create = .true.) .le. 0) then !{
344 call mpp_error(fatal, trim(error_header) // &
345 ' Could not add ' // trim(name) // ' to "' // trim(good_name_list_use) // '" list')
346 endif !}
347 endif !}
348endif !}
349
350return
351
352end subroutine fm_util_set_value_real_ !}
353
354!#######################################################################
355!> @}
356! close documentation grouping