FV3 Bundle
fms_io_unstructured_register_restart_field.inc
Go to the documentation of this file.
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 !----------
20 !ug support
21 
22 !------------------------------------------------------------------------------
23 !>Add a real scalar field to a restart object (restart_file_type). Return
24 !!the index of the inputted field in the fileObj%var array.
25 function fms_io_unstructured_register_restart_field_r_0d(fileObj, &
26  filename, &
27  fieldname, &
28  fdata_0d, &
29  domain, &
30  mandatory, &
31  data_default, &
32  longname, &
33  units, &
34  read_only, &
35  restart_owns_data) &
36  result(restart_index)
37 
38  !Inputs/Outputs
39  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
40  character(len=*),intent(in) :: filename !<The name of a file.
41  character(len=*),intent(in) :: fieldname !<The name of a field.
42  real,intent(in),target :: fdata_0d !<Some data.
43  type(domainUG),intent(in),target :: domain !<An unstructured mpp_domain.
44  logical,intent(in),optional :: mandatory !<Flag telling if the field is mandatory for the restart.
45  real,intent(in),optional :: data_default !<A default value for the data.
46  character(len=*),intent(in),optional :: longname !<A more descriptive name of the field.
47  character(len=*),intent(in),optional :: units !<Units for the field.
48  logical(INT_KIND),intent(in),optional :: read_only !<Tells whether or not the variable will be written to the restart file.
49  logical(INT_KIND),intent(in),optional :: restart_owns_data !<Tells if the data will be deallocated when the restart object is deallocated.
50  integer(INT_KIND) :: restart_index !<Index of the inputted field in the fileObj%var array.
51 
52  !Local variables
53  type(domainUG),pointer :: io_domain !<Pointer to an unstructured I/O domain.
54  integer(INT_KIND) :: io_domain_npes !<The number of ranks in the unstructured I/O domain pelist.
55  integer(INT_KIND),dimension(:),allocatable :: pelist !<A pelist.
56  real,dimension(:),allocatable :: fdata_per_rank !<Array used to gather the scalar field values.
57  integer(INT_KIND) :: index_field !<Index of the inputted field in the fileObj%var array.
58  integer(INT_KIND),dimension(NIDX) :: field_dimension_sizes !<Array of dimension sizes for the field.
59  integer(INT_KIND),dimension(1) :: field_dimension_order !<Array telling the ordering of the dimensions for the field.
60 
61  !Make sure that the module has been initialized.
62  if (.not. module_is_initialized) then
63  call mpp_error(FATAL, &
64  "fms_io_unstructured_register_restart_field_r_0d:" &
65  //" you must first call fms_io_init")
66  endif
67 
68  !Make sure that the value of the scalar field is same across all ranks
69  !in an I/O domain pelist.
70  io_domain => null()
71  io_domain => mpp_get_UG_io_domain(domain)
72  io_domain_npes = mpp_get_UG_domain_npes(io_domain)
73  allocate(pelist(io_domain_npes))
74  call mpp_get_UG_domain_pelist(io_domain, &
75  pelist)
76  allocate(fdata_per_rank(io_domain_npes))
77  fdata_per_rank = 0.0
78  call mpp_gather((/fdata_0d/), &
79  fdata_per_rank, &
80  pelist)
81  if (mpp_pe() .eq. pelist(1)) then
82  if (maxval(fdata_per_rank) .ne. fdata_0d .or. &
83  minval(fdata_per_rank) .ne. fdata_0d) then
84  call mpp_error(FATAL, &
85  "fms_io_unstructured_register_restart_field_r_0d:" &
86  //" the scalar field data is not consistent across" &
87  //" all ranks in the I/O domain pelist.")
88  endif
89  endif
90  io_domain => null()
91  deallocate(pelist)
92  deallocate(fdata_per_rank)
93 
94  !Set the dimension sizes for the field. These correspond to:
95  !field_dimension_sizes(XIDX) = x-dimension size
96  !field_dimension_sizes(YIDX) = y-dimension size
97  !field_dimension_sizes(CIDX) = c-dimension size
98  !field_dimension_sizes(ZIDX) = z-dimension size
99  !field_dimension_sizes(HIDX) = h-dimension size
100  !field_dimension_sizes(TIDX) = t-dimension size
101  !field_dimension_sizes(UIDX) = u-dimension size
102  !field_dimension_sizes(CCIDX) = cc-dimension size
103  field_dimension_sizes = 1
104 
105  !Set the ordering of the dimensions for the field.
106  field_dimension_order(1) = TIDX
107 
108  !Add a field to a restart object (restart_file_type). Get the index of the
109  !inputted field in the fileObj%var array.
110  call fms_io_unstructured_setup_one_field(fileObj, &
111  filename, &
112  fieldname, &
113  field_dimension_order, &
114  field_dimension_sizes, &
115  index_field, &
116  domain, &
117  mandatory=mandatory, &
118  data_default=data_default, &
119  longname=longname, &
120  units=units, &
121  read_only=read_only, &
122  owns_data=restart_owns_data)
123 
124  !Point to the inputted data and return the "index_field" for the field.
125  fileObj%p0dr(fileObj%var(index_field)%siz(4),index_field)%p => fdata_0d
126  fileObj%var(index_field)%ndim = 0
127  restart_index = index_field
128 
129  return
130 end function fms_io_unstructured_register_restart_field_r_0d
131 
132 !------------------------------------------------------------------------------
133 !>Add a real 1D field to a restart object (restart_file_type), where the
134 !!field is assumed to be along the unstructured axis. Return
135 !!the index of the inputted field in the fileObj%var array.
136 function fms_io_unstructured_register_restart_field_r_1d(fileObj, &
137  filename, &
138  fieldname, &
139  fdata_1d, &
140  fdata_1d_axes, &
141  domain, &
142  mandatory, &
143  data_default, &
144  longname, &
145  units, &
146  read_only, &
147  restart_owns_data) &
148  result(restart_index)
149 
150  !Inputs/Outputs
151  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
152  character(len=*),intent(in) :: filename !<The name of a file.
153  character(len=*),intent(in) :: fieldname !<The name of a field.
154  real,dimension(:),intent(in),target :: fdata_1d !<Some data.
155  integer(INT_KIND),dimension(1) :: fdata_1d_axes !<An array describing the axes for the data.
156  type(domainUG),intent(in),target :: domain !<An unstructured mpp_domain.
157  logical,intent(in),optional :: mandatory !<Flag telling if the field is mandatory for the restart.
158  real,intent(in),optional :: data_default !<A default value for the data.
159  character(len=*),intent(in),optional :: longname !<A more descriptive name of the field.
160  character(len=*),intent(in),optional :: units !<Units for the field.
161  logical(INT_KIND),intent(in),optional :: read_only !<Tells whether or not the variable will be written to the restart file.
162  logical(INT_KIND),intent(in),optional :: restart_owns_data !<Tells if the data will be deallocated when the restart object is deallocated.
163  integer(INT_KIND) :: restart_index !<Index of the inputted field in the fileObj%var array.
164 
165  !Local variables
166  integer(INT_KIND) :: index_field !<Index of the inputted field in the fileObj%var array.
167  integer(INT_KIND),dimension(NIDX) :: field_dimension_sizes !<Array of dimension sizes for the field.
168 
169  !Make sure that the module has been initialized.
170  if (.not. module_is_initialized) then
171  call mpp_error(FATAL, &
172  "fms_io_unstructured_register_restart_field_r_1d:" &
173  //" you must first call fms_io_init")
174  endif
175 
176  !Make sure that at least one axis was registered to the restart object.
177  if (.not. allocated(fileObj%axes)) then
178  call mpp_error(FATAL, &
179  "fms_io_unstructured_register_restart_field_r_1d:" &
180  //" no axes have been registered for the restart" &
181  //" object.")
182  endif
183 
184  !Make sure that the first dimension of the field is a "compressed" axis,
185  !and that it corresponds to an axis that has been registered to the
186  !restart object.
187  field_dimension_sizes = 1
188  if (fdata_1d_axes(1) .eq. CIDX) then
189  if (.not. allocated(fileObj%axes(CIDX)%idx)) then
190  call mpp_error(FATAL, &
191  "fms_io_unstructured_register_restart_field_r_1d:" &
192  //" a compressed c-axis was not registered" &
193  //" to the restart object.")
194  endif
195  if (size(fdata_1d,1) .ne. fileObj%axes(CIDX)%nelems_for_current_rank) then
196  call mpp_error(FATAL, &
197  "fms_io_unstructured_register_restart_field_r_1d:" &
198  //" the size of the input data does not" &
199  //" match the size of the registered" &
200  //" compressed c-axis.")
201  endif
202  field_dimension_sizes(CIDX) = size(fdata_1d,1)
203  elseif (fdata_1d_axes(1) .eq. HIDX) then
204  if (.not. allocated(fileObj%axes(HIDX)%idx)) then
205  call mpp_error(FATAL, &
206  "fms_io_unstructured_register_restart_field_r_1d:" &
207  //" a compressed h-axis was not registered" &
208  //" to the restart object.")
209  endif
210  if (size(fdata_1d,1) .ne. fileObj%axes(HIDX)%nelems_for_current_rank) then
211  call mpp_error(FATAL, &
212  "fms_io_unstructured_register_restart_field_r_1d:" &
213  //" the size of the input data does not" &
214  //" match the size of the registered" &
215  //" compressed h-axis.")
216  endif
217  field_dimension_sizes(HIDX) = size(fdata_1d,1)
218  else
219  call mpp_error(FATAL, &
220  "fms_io_unstructured_register_restart_field_r_1d:" &
221  //" One dimensional fields must be compressed.")
222  endif
223 
224  !Add a field to a restart object (restart_file_type). Get the index of the
225  !inputted field in the fileObj%var array.
226  call fms_io_unstructured_setup_one_field(fileObj, &
227  filename, &
228  fieldname, &
229  fdata_1d_axes, &
230  field_dimension_sizes, &
231  index_field, &
232  domain, &
233  mandatory=mandatory, &
234  data_default=data_default, &
235  longname=longname, &
236  units=units, &
237  read_only=read_only, &
238  owns_data=restart_owns_data)
239 
240  !Point to the inputted data and return the "index_field" for the field.
241  fileObj%p1dr(fileObj%var(index_field)%siz(4),index_field)%p => fdata_1d
242  fileObj%var(index_field)%ndim = 1
243  restart_index = index_field
244 
245  return
246 end function fms_io_unstructured_register_restart_field_r_1d
247 
248 !------------------------------------------------------------------------------
249 !>Add a real 2D field to a restart object (restart_file_type), where the
250 !!field's 1st axis assumed to be along the unstructured axis and the field's
251 !!2nd axis is assumed to be along the z-axis. Return the index of the
252 !!inputted field in the fileObj%var array.
253 function fms_io_unstructured_register_restart_field_r_2d(fileObj, &
254  filename, &
255  fieldname, &
256  fdata_2d, &
257  fdata_2d_axes, &
258  domain, &
259  mandatory, &
260  data_default, &
261  longname, &
262  units, &
263  read_only, &
264  restart_owns_data) &
265  result(restart_index)
266 
267  !Inputs/Outputs
268  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
269  character(len=*),intent(in) :: filename !<The name of a file.
270  character(len=*),intent(in) :: fieldname !<The name of a field.
271  real,dimension(:,:),intent(in),target :: fdata_2d !<Some data.
272  integer(INT_KIND),dimension(2) :: fdata_2d_axes !<An array describing the axes for the data.
273  type(domainUG),intent(in),target :: domain !<An unstructured mpp_domain.
274  logical,intent(in),optional :: mandatory !<Flag telling if the field is mandatory for the restart.
275  real,intent(in),optional :: data_default !<A default value for the data.
276  character(len=*),intent(in),optional :: longname !<A more descriptive name of the field.
277  character(len=*),intent(in),optional :: units !<Units for the field.
278  logical(INT_KIND),intent(in),optional :: read_only !<Tells whether or not the variable will be written to the restart file.
279  logical(INT_KIND),intent(in),optional :: restart_owns_data !<Tells if the data will be deallocated when the restart object is deallocated.
280  integer(INT_KIND) :: restart_index !<Index of the inputted field in the fileObj%var array.
281 
282  !Local variables
283  integer(INT_KIND) :: index_field !<Index of the inputted field in the fileObj%var array.
284  integer(INT_KIND),dimension(NIDX) :: field_dimension_sizes !<Array of dimension sizes for the field.
285 
286  !Make sure that the module has been initialized.
287  if (.not. module_is_initialized) then
288  call mpp_error(FATAL, &
289  "fms_io_unstructured_register_restart_field_r_2d:" &
290  //" you must first call fms_io_init")
291  endif
292 
293  !Make sure that at least one axis was registered to the restart object.
294  if (.not. allocated(fileObj%axes)) then
295  call mpp_error(FATAL, &
296  "fms_io_unstructured_register_restart_field_r_2d:" &
297  //" no axes have been registered for the restart" &
298  //" object.")
299  endif
300 
301  !Make sure that the first dimension of the field is a "compressed" axis,
302  !and that it corresponds to an axis that has been registered to the
303  !restart object.
304  field_dimension_sizes = 1
305  if (fdata_2d_axes(1) .eq. CIDX) then
306  if (.not. allocated(fileObj%axes(CIDX)%idx)) then
307  call mpp_error(FATAL, &
308  "fms_io_unstructured_register_restart_field_r_2d:" &
309  //" a compressed c-axis was not registered" &
310  //" to the restart object.")
311  endif
312  if (size(fdata_2d,1) .ne. fileObj%axes(CIDX)%nelems_for_current_rank) then
313  call mpp_error(FATAL, &
314  "fms_io_unstructured_register_restart_field_r_2d:" &
315  //" the size of the input data does not" &
316  //" match the size of the registered" &
317  //" compressed c-axis.")
318  endif
319  field_dimension_sizes(CIDX) = size(fdata_2d,1)
320  elseif (fdata_2d_axes(1) .eq. HIDX) then
321  if (.not. allocated(fileObj%axes(HIDX)%idx)) then
322  call mpp_error(FATAL, &
323  "fms_io_unstructured_register_restart_field_r_2d:" &
324  //" a compressed h-axis was not registered" &
325  //" to the restart object.")
326  endif
327  if (size(fdata_2d,1) .ne. fileObj%axes(HIDX)%nelems_for_current_rank) then
328  call mpp_error(FATAL, &
329  "fms_io_unstructured_register_restart_field_r_2d:" &
330  //" the size of the input data does not" &
331  //" match the size of the registered" &
332  //" compressed h-axis.")
333  endif
334  field_dimension_sizes(HIDX) = size(fdata_2d,1)
335  else
336  call mpp_error(FATAL, &
337  "fms_io_unstructured_register_restart_field_r_2d:" &
338  //" The first dimension of the field must be a" &
339  //" compressed dimension.")
340  endif
341 
342  !Make sure that the second dimension of the inputted field corresponds to
343  !either a registered z- or cc-axis.
344  if (fdata_2d_axes(2) .eq. ZIDX) then
345  if (.not. associated(fileObj%axes(ZIDX)%data)) then
346  call mpp_error(FATAL, &
347  "fms_io_unstructured_register_restart_field_r_2d:" &
348  //" a z-axis was not registered to the" &
349  //" restart object.")
350  endif
351  if (size(fdata_2d,2) .ne. size(fileObj%axes(ZIDX)%data)) then
352  call mpp_error(FATAL, &
353  "fms_io_unstructured_register_restart_field_r_2d:" &
354  //" the size of the input data does not" &
355  //" match the size of the registered" &
356  //" z-axis.")
357  endif
358  field_dimension_sizes(ZIDX) = size(fdata_2d,2)
359  elseif (fdata_2d_axes(2) .eq. CCIDX) then
360  if (.not. associated(fileObj%axes(CCIDX)%data)) then
361  call mpp_error(FATAL, &
362  "fms_io_unstructured_register_restart_field_r_2d:" &
363  //" a cc-axis was not registered to the" &
364  //" restart object.")
365  endif
366  if (size(fdata_2d,2) .ne. size(fileObj%axes(CCIDX)%data)) then
367  call mpp_error(FATAL, &
368  "fms_io_unstructured_register_restart_field_r_2d:" &
369  //" the size of the input data does not" &
370  //" match the size of the registered" &
371  //" cc-axis.")
372  endif
373  field_dimension_sizes(CCIDX) = size(fdata_2d,2)
374  else
375  call mpp_error(FATAL, &
376  "fms_io_unstructured_register_restart_field_r_2d:" &
377  //" unsupported axis parameter for the second" &
378  //" dimension of the field.")
379  endif
380 
381  !Add a field to a restart object (restart_file_type). Get the index of the
382  !inputted field in the fileObj%var array.
383  call fms_io_unstructured_setup_one_field(fileObj, &
384  filename, &
385  fieldname, &
386  fdata_2d_axes, &
387  field_dimension_sizes, &
388  index_field, &
389  domain, &
390  mandatory=mandatory, &
391  data_default=data_default, &
392  longname=longname, &
393  units=units, &
394  read_only=read_only, &
395  owns_data=restart_owns_data)
396 
397  !Point to the inputted data and return the "index_field" for the field.
398  fileObj%p2dr(fileObj%var(index_field)%siz(4),index_field)%p => fdata_2d
399  fileObj%var(index_field)%ndim = 2
400  restart_index = index_field
401 
402  return
403 end function fms_io_unstructured_register_restart_field_r_2d
404 
405 !------------------------------------------------------------------------------
406 !>Add a real 3D field to a restart object (restart_file_type), where the
407 !!field's 1st axis assumed to be along the unstructured axis, the fields's
408 !!second axis is assumed to be along the z-axis, and the field's third axis
409 !!is assumed to be along the cc-axis (???). Return the index of the
410 !!inputted field in the fileObj%var array.
411 function fms_io_unstructured_register_restart_field_r_3d(fileObj, &
412  filename, &
413  fieldname, &
414  fdata_3d, &
415  fdata_3d_axes, &
416  domain, &
417  mandatory, &
418  data_default, &
419  longname, &
420  units, &
421  read_only, &
422  restart_owns_data) &
423  result(restart_index)
424 
425  !Inputs/Outputs
426  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
427  character(len=*),intent(in) :: filename !<The name of a file.
428  character(len=*),intent(in) :: fieldname !<The name of a field.
429  real,dimension(:,:,:),intent(in),target :: fdata_3d !<Some data.
430  integer(INT_KIND),dimension(3) :: fdata_3d_axes !<An array describing the axes for the data.
431  type(domainUG),intent(in),target :: domain !<An unstructured mpp_domain.
432  logical,intent(in),optional :: mandatory !<Flag telling if the field is mandatory for the restart.
433  real,intent(in),optional :: data_default !<A default value for the data.
434  character(len=*),intent(in),optional :: longname !<A more descriptive name of the field.
435  character(len=*),intent(in),optional :: units !<Units for the field.
436  logical(INT_KIND),intent(in),optional :: read_only !<Tells whether or not the variable will be written to the restart file.
437  logical(INT_KIND),intent(in),optional :: restart_owns_data !<Tells if the data will be deallocated when the restart object is deallocated.
438  integer(INT_KIND) :: restart_index !<Index of the inputted field in the fileObj%var array.
439 
440  !Local variables
441  integer(INT_KIND) :: index_field !<Index of the inputted field in the fileObj%var array.
442  integer(INT_KIND),dimension(NIDX) :: field_dimension_sizes !<Array of dimension sizes for the field.
443 
444  !Make sure that the module has been initialized.
445  if (.not. module_is_initialized) then
446  call mpp_error(FATAL, &
447  "fms_io_unstructured_register_restart_field_r_3d:" &
448  //" you must first call fms_io_init")
449  endif
450 
451  !Make sure that at least one axis was registered to the restart object.
452  if (.not. allocated(fileObj%axes)) then
453  call mpp_error(FATAL, &
454  "fms_io_unstructured_register_restart_field_r_3d:" &
455  //" no axes have been registered for the restart" &
456  //" object.")
457  endif
458 
459  !Make sure that the first dimension of the field is a "compressed" axis,
460  !and that it corresponds to an axis that has been registered to the
461  !restart object.
462  field_dimension_sizes = 1
463  if (fdata_3d_axes(1) .eq. CIDX) then
464  if (.not. allocated(fileObj%axes(CIDX)%idx)) then
465  call mpp_error(FATAL, &
466  "fms_io_unstructured_register_restart_field_r_3d:" &
467  //" a compressed c-axis was not registered" &
468  //" to the restart object.")
469  endif
470  if (size(fdata_3d,1) .ne. fileObj%axes(CIDX)%nelems_for_current_rank) then
471  call mpp_error(FATAL, &
472  "fms_io_unstructured_register_restart_field_r_3d:" &
473  //" the size of the input data does not" &
474  //" match the size of the registered" &
475  //" compressed c-axis.")
476  endif
477  field_dimension_sizes(CIDX) = size(fdata_3d,1)
478  elseif (fdata_3d_axes(1) .eq. HIDX) then
479  if (.not. allocated(fileObj%axes(HIDX)%idx)) then
480  call mpp_error(FATAL, &
481  "fms_io_unstructured_register_restart_field_r_3d:" &
482  //" a compressed h-axis was not registered" &
483  //" to the restart object.")
484  endif
485  if (size(fdata_3d,1) .ne. fileObj%axes(HIDX)%nelems_for_current_rank) then
486  call mpp_error(FATAL, &
487  "fms_io_unstructured_register_restart_field_r_3d:" &
488  //" the size of the input data does not" &
489  //" match the size of the registered" &
490  //" compressed h-axis.")
491  endif
492  field_dimension_sizes(HIDX) = size(fdata_3d,1)
493  else
494  call mpp_error(FATAL, &
495  "fms_io_unstructured_register_restart_field_r_3d:" &
496  //" The first dimension of the field must be a" &
497  //" compressed dimension.")
498  endif
499 
500  !Make sure that the second and third dimensions of the inputted field
501  !corresponds to some combination of registered z- and cc-axes.
502  if (.not. associated(fileObj%axes(ZIDX)%data)) then
503  call mpp_error(FATAL, &
504  "fms_io_unstructured_register_restart_field_r_3d:" &
505  //" a z-axis was not registered to the" &
506  //" restart object.")
507  endif
508  if (.not. associated(fileObj%axes(CCIDX)%data)) then
509  call mpp_error(FATAL, &
510  "fms_io_unstructured_register_restart_field_r_3d:" &
511  //" a cc-axis was not registered to the" &
512  //" restart object.")
513  endif
514  if (fdata_3d_axes(2) .eq. ZIDX) then
515  if (size(fdata_3d,2) .ne. size(fileObj%axes(ZIDX)%data)) then
516  call mpp_error(FATAL, &
517  "fms_io_unstructured_register_restart_field_r_3d:" &
518  //" the size of the input data does not" &
519  //" match the size of the registered" &
520  //" z-axis.")
521  endif
522  field_dimension_sizes(ZIDX) = size(fdata_3d,2)
523  if (fdata_3d_axes(3) .ne. CCIDX) then
524  call mpp_error(FATAL, &
525  "fms_io_unstructured_register_restart_field_r_3d:" &
526  //" unsupported axis parameter for the third" &
527  //" dimension of the field.")
528  elseif (size(fdata_3d,3) .ne. size(fileObj%axes(CCIDX)%data)) then
529  call mpp_error(FATAL, &
530  "fms_io_unstructured_register_restart_field_r_3d:" &
531  //" the size of the input data does not" &
532  //" match the size of the registered" &
533  //" cc-axis.")
534 
535  else
536  field_dimension_sizes(CCIDX) = size(fdata_3d,3)
537  endif
538  elseif (fdata_3d_axes(2) .eq. CCIDX) then
539  if (size(fdata_3d,2) .ne. size(fileObj%axes(CCIDX)%data)) then
540  call mpp_error(FATAL, &
541  "fms_io_unstructured_register_restart_field_r_3d:" &
542  //" the size of the input data does not" &
543  //" match the size of the registered" &
544  //" cc-axis.")
545  endif
546  field_dimension_sizes(CCIDX) = size(fdata_3d,2)
547  if (fdata_3d_axes(3) .ne. ZIDX) then
548  call mpp_error(FATAL, &
549  "fms_io_unstructured_register_restart_field_r_3d:" &
550  //" unsupported axis parameter for the third" &
551  //" dimension of the field.")
552  elseif (size(fdata_3d,3) .ne. size(fileObj%axes(ZIDX)%data)) then
553  call mpp_error(FATAL, &
554  "fms_io_unstructured_register_restart_field_r_3d:" &
555  //" the size of the input data does not" &
556  //" match the size of the registered" &
557  //" z-axis.")
558  else
559  field_dimension_sizes(ZIDX) = size(fdata_3d,3)
560  endif
561  else
562  call mpp_error(FATAL, &
563  "fms_io_unstructured_register_restart_field_r_3d:" &
564  //" unsupported axis parameter for the second" &
565  //" dimension of the field.")
566  endif
567 
568  !Add a field to a restart object (restart_file_type). Get the index of the
569  !inputted field in the fileObj%var array.
570  call fms_io_unstructured_setup_one_field(fileObj, &
571  filename, &
572  fieldname, &
573  fdata_3d_axes, &
574  field_dimension_sizes, &
575  index_field, &
576  domain, &
577  mandatory=mandatory, &
578  data_default=data_default, &
579  longname=longname, &
580  units=units, &
581  read_only=read_only, &
582  owns_data=restart_owns_data)
583 
584  !Point to the inputted data and return the "index_field" for the field.
585  fileObj%p3dr(fileObj%var(index_field)%siz(4),index_field)%p => fdata_3d
586  fileObj%var(index_field)%ndim = 3
587  restart_index = index_field
588 
589  return
590 end function fms_io_unstructured_register_restart_field_r_3d
591 
592 #ifdef OVERLOAD_R8
593 !------------------------------------------------------------------------------
594 !>Add a double_kind 2D field to a restart object (restart_file_type), where the
595 !!field's 1st axis assumed to be along the unstructured axis and the field's
596 !!2nd axis is assumed to be along the z-axis. Return the index of the
597 !!inputted field in the fileObj%var array.
598 function fms_io_unstructured_register_restart_field_r8_2d(fileObj, &
599  filename, &
600  fieldname, &
601  fdata_2d, &
602  fdata_2d_axes, &
603  domain, &
604  mandatory, &
605  data_default, &
606  longname, &
607  units, &
608  read_only, &
609  restart_owns_data) &
610  result(restart_index)
611 
612  !Inputs/Outputs
613  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
614  character(len=*),intent(in) :: filename !<The name of a file.
615  character(len=*),intent(in) :: fieldname !<The name of a field.
616  real(DOUBLE_KIND),dimension(:,:),intent(in),target :: fdata_2d !<Some data.
617  integer(INT_KIND),dimension(2) :: fdata_2d_axes !<An array describing the axes for the data.
618  type(domainUG),intent(in),target :: domain !<An unstructured mpp_domain.
619  logical,intent(in),optional :: mandatory !<Flag telling if the field is mandatory for the restart.
620  real(DOUBLE_KIND),intent(in),optional :: data_default !<A default value for the data.
621  character(len=*),intent(in),optional :: longname !<A more descriptive name of the field.
622  character(len=*),intent(in),optional :: units !<Units for the field.
623  logical(INT_KIND),intent(in),optional :: read_only !<Tells whether or not the variable will be written to the restart file.
624  logical(INT_KIND),intent(in),optional :: restart_owns_data !<Tells if the data will be deallocated when the restart object is deallocated.
625  integer(INT_KIND) :: restart_index !<Index of the inputted field in the fileObj%var array.
626 
627  !Local variables
628  integer(INT_KIND) :: index_field !<Index of the inputted field in the fileObj%var array.
629  integer(INT_KIND),dimension(NIDX) :: field_dimension_sizes !<Array of dimension sizes for the field.
630 
631  !QUICK ERROR OUT AS SUPPORT NOT YET FULLY IMPLEMENTED
632  call mpp_error(FATAL, &
633  "fms_io_unstructured_register_restart_field_r8_2d:" &
634  //" support has not yet been fully implemented")
635 
636  !Make sure that the module has been initialized.
637  if (.not. module_is_initialized) then
638  call mpp_error(FATAL, &
639  "fms_io_unstructured_register_restart_field_r8_2d:" &
640  //" you must first call fms_io_init")
641  endif
642 
643  !Make sure that at least one axis was registered to the restart object.
644  if (.not. allocated(fileObj%axes)) then
645  call mpp_error(FATAL, &
646  "fms_io_unstructured_register_restart_field_r8_2d:" &
647  //" no axes have been registered for the restart" &
648  //" object.")
649  endif
650 
651  !Make sure that the first dimension of the field is a "compressed" axis,
652  !and that it corresponds to an axis that has been registered to the
653  !restart object.
654  field_dimension_sizes = 1
655  if (fdata_2d_axes(1) .eq. CIDX) then
656  if (.not. allocated(fileObj%axes(CIDX)%idx)) then
657  call mpp_error(FATAL, &
658  "fms_io_unstructured_register_restart_field_r8_2d:" &
659  //" a compressed c-axis was not registered" &
660  //" to the restart object.")
661  endif
662  if (size(fdata_2d,1) .ne. fileObj%axes(CIDX)%nelems_for_current_rank) then
663  call mpp_error(FATAL, &
664  "fms_io_unstructured_register_restart_field_r8_2d:" &
665  //" the size of the input data does not" &
666  //" match the size of the registered" &
667  //" compressed c-axis.")
668  endif
669  field_dimension_sizes(CIDX) = size(fdata_2d,1)
670  elseif (fdata_2d_axes(1) .eq. HIDX) then
671  if (.not. allocated(fileObj%axes(HIDX)%idx)) then
672  call mpp_error(FATAL, &
673  "fms_io_unstructured_register_restart_field_r8_2d:" &
674  //" a compressed h-axis was not registered" &
675  //" to the restart object.")
676  endif
677  if (size(fdata_2d,1) .ne. fileObj%axes(HIDX)%nelems_for_current_rank) then
678  call mpp_error(FATAL, &
679  "fms_io_unstructured_register_restart_field_r8_2d:" &
680  //" the size of the input data does not" &
681  //" match the size of the registered" &
682  //" compressed h-axis.")
683  endif
684  field_dimension_sizes(HIDX) = size(fdata_2d,1)
685  else
686  call mpp_error(FATAL, &
687  "fms_io_unstructured_register_restart_field_r8_2d:" &
688  //" The first dimension of the field must be a" &
689  //" compressed dimension.")
690  endif
691 
692  !Make sure that the second dimension of the inputted field corresponds to
693  !either a registered z- or cc-axis.
694  if (fdata_2d_axes(2) .eq. ZIDX) then
695  if (.not. associated(fileObj%axes(ZIDX)%data)) then
696  call mpp_error(FATAL, &
697  "fms_io_unstructured_register_restart_field_r8_2d:" &
698  //" a z-axis was not registered to the" &
699  //" restart object.")
700  endif
701  if (size(fdata_2d,2) .ne. size(fileObj%axes(ZIDX)%data)) then
702  call mpp_error(FATAL, &
703  "fms_io_unstructured_register_restart_field_r8_2d:" &
704  //" the size of the input data does not" &
705  //" match the size of the registered" &
706  //" z-axis.")
707  endif
708  field_dimension_sizes(ZIDX) = size(fdata_2d,2)
709  elseif (fdata_2d_axes(2) .eq. CCIDX) then
710  if (.not. associated(fileObj%axes(CCIDX)%data)) then
711  call mpp_error(FATAL, &
712  "fms_io_unstructured_register_restart_field_r8_2d:" &
713  //" a cc-axis was not registered to the" &
714  //" restart object.")
715  endif
716  if (size(fdata_2d,2) .ne. size(fileObj%axes(CCIDX)%data)) then
717  call mpp_error(FATAL, &
718  "fms_io_unstructured_register_restart_field_r8_2d:" &
719  //" the size of the input data does not" &
720  //" match the size of the registered" &
721  //" cc-axis.")
722  endif
723  field_dimension_sizes(CCIDX) = size(fdata_2d,2)
724  else
725  call mpp_error(FATAL, &
726  "fms_io_unstructured_register_restart_field_r8_2d:" &
727  //" unsupported axis parameter for the second" &
728  //" dimension of the field.")
729  endif
730 
731  !Add a field to a restart object (restart_file_type). Get the index of the
732  !inputted field in the fileObj%var array.
733  call fms_io_unstructured_setup_one_field(fileObj, &
734  filename, &
735  fieldname, &
736  fdata_2d_axes, &
737  field_dimension_sizes, &
738  index_field, &
739  domain, &
740  mandatory=mandatory, &
741  data_default=real(data_default), &
742  longname=longname, &
743  units=units, &
744  read_only=read_only, &
745  owns_data=restart_owns_data)
746 
747  !Point to the inputted data and return the "index_field" for the field.
748  fileObj%p2dr8(fileObj%var(index_field)%siz(4),index_field)%p => fdata_2d
749  fileObj%var(index_field)%ndim = 2
750  restart_index = index_field
751 
752  return
753 end function fms_io_unstructured_register_restart_field_r8_2d
754 
755 !------------------------------------------------------------------------------
756 !>Add a double_kind 3D field to a restart object (restart_file_type), where the
757 !!field's 1st axis assumed to be along the unstructured axis, the fields's
758 !!second axis is assumed to be along the z-axis, and the field's third axis
759 !!is assumed to be along the cc-axis (???). Return the index of the
760 !!inputted field in the fileObj%var array.
761 function fms_io_unstructured_register_restart_field_r8_3d(fileObj, &
762  filename, &
763  fieldname, &
764  fdata_3d, &
765  fdata_3d_axes, &
766  domain, &
767  mandatory, &
768  data_default, &
769  longname, &
770  units, &
771  read_only, &
772  restart_owns_data) &
773  result(restart_index)
774 
775  !Inputs/Outputs
776  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
777  character(len=*),intent(in) :: filename !<The name of a file.
778  character(len=*),intent(in) :: fieldname !<The name of a field.
779  real(DOUBLE_KIND),dimension(:,:,:),intent(in),target :: fdata_3d !<Some data.
780  integer(INT_KIND),dimension(3) :: fdata_3d_axes !<An array describing the axes for the data.
781  type(domainUG),intent(in),target :: domain !<An unstructured mpp_domain.
782  logical,intent(in),optional :: mandatory !<Flag telling if the field is mandatory for the restart.
783  real(DOUBLE_KIND),intent(in),optional :: data_default !<A default value for the data.
784  character(len=*),intent(in),optional :: longname !<A more descriptive name of the field.
785  character(len=*),intent(in),optional :: units !<Units for the field.
786  logical(INT_KIND),intent(in),optional :: read_only !<Tells whether or not the variable will be written to the restart file.
787  logical(INT_KIND),intent(in),optional :: restart_owns_data !<Tells if the data will be deallocated when the restart object is deallocated.
788  integer(INT_KIND) :: restart_index !<Index of the inputted field in the fileObj%var array.
789 
790  !Local variables
791  integer(INT_KIND) :: index_field !<Index of the inputted field in the fileObj%var array.
792  integer(INT_KIND),dimension(NIDX) :: field_dimension_sizes !<Array of dimension sizes for the field.
793 
794  !QUICK ERROR OUT AS SUPPORT NOT YET FULLY IMPLEMENTED
795  call mpp_error(FATAL, &
796  "fms_io_unstructured_register_restart_field_r8_3d:" &
797  //" support has not yet been fully implemented")
798 
799  !Make sure that the module has been initialized.
800  if (.not. module_is_initialized) then
801  call mpp_error(FATAL, &
802  "fms_io_unstructured_register_restart_field_r8_3d:" &
803  //" you must first call fms_io_init")
804  endif
805 
806  !Make sure that at least one axis was registered to the restart object.
807  if (.not. allocated(fileObj%axes)) then
808  call mpp_error(FATAL, &
809  "fms_io_unstructured_register_restart_field_r8_3d:" &
810  //" no axes have been registered for the restart" &
811  //" object.")
812  endif
813 
814  !Make sure that the first dimension of the field is a "compressed" axis,
815  !and that it corresponds to an axis that has been registered to the
816  !restart object.
817  field_dimension_sizes = 1
818  if (fdata_3d_axes(1) .eq. CIDX) then
819  if (.not. allocated(fileObj%axes(CIDX)%idx)) then
820  call mpp_error(FATAL, &
821  "fms_io_unstructured_register_restart_field_r8_3d:" &
822  //" a compressed c-axis was not registered" &
823  //" to the restart object.")
824  endif
825  if (size(fdata_3d,1) .ne. fileObj%axes(CIDX)%nelems_for_current_rank) then
826  call mpp_error(FATAL, &
827  "fms_io_unstructured_register_restart_field_r8_3d:" &
828  //" the size of the input data does not" &
829  //" match the size of the registered" &
830  //" compressed c-axis.")
831  endif
832  field_dimension_sizes(CIDX) = size(fdata_3d,1)
833  elseif (fdata_3d_axes(1) .eq. HIDX) then
834  if (.not. allocated(fileObj%axes(HIDX)%idx)) then
835  call mpp_error(FATAL, &
836  "fms_io_unstructured_register_restart_field_r8_3d:" &
837  //" a compressed h-axis was not registered" &
838  //" to the restart object.")
839  endif
840  if (size(fdata_3d,1) .ne. fileObj%axes(HIDX)%nelems_for_current_rank) then
841  call mpp_error(FATAL, &
842  "fms_io_unstructured_register_restart_field_r8_3d:" &
843  //" the size of the input data does not" &
844  //" match the size of the registered" &
845  //" compressed h-axis.")
846  endif
847  field_dimension_sizes(HIDX) = size(fdata_3d,1)
848  else
849  call mpp_error(FATAL, &
850  "fms_io_unstructured_register_restart_field_r8_3d:" &
851  //" The first dimension of the field must be a" &
852  //" compressed dimension.")
853  endif
854 
855  !Make sure that the second and third dimensions of the inputted field
856  !corresponds to some combination of registered z- and cc-axes.
857  if (.not. associated(fileObj%axes(ZIDX)%data)) then
858  call mpp_error(FATAL, &
859  "fms_io_unstructured_register_restart_field_r8_3d:" &
860  //" a z-axis was not registered to the" &
861  //" restart object.")
862  endif
863  if (.not. associated(fileObj%axes(CCIDX)%data)) then
864  call mpp_error(FATAL, &
865  "fms_io_unstructured_register_restart_field_r8_3d:" &
866  //" a cc-axis was not registered to the" &
867  //" restart object.")
868  endif
869  if (fdata_3d_axes(2) .eq. ZIDX) then
870  if (size(fdata_3d,2) .ne. size(fileObj%axes(ZIDX)%data)) then
871  call mpp_error(FATAL, &
872  "fms_io_unstructured_register_restart_field_r8_3d:" &
873  //" the size of the input data does not" &
874  //" match the size of the registered" &
875  //" z-axis.")
876  endif
877  field_dimension_sizes(ZIDX) = size(fdata_3d,2)
878  if (fdata_3d_axes(3) .ne. CCIDX) then
879  call mpp_error(FATAL, &
880  "fms_io_unstructured_register_restart_field_r8_3d:" &
881  //" unsupported axis parameter for the third" &
882  //" dimension of the field.")
883  elseif (size(fdata_3d,3) .ne. size(fileObj%axes(CCIDX)%data)) then
884  call mpp_error(FATAL, &
885  "fms_io_unstructured_register_restart_field_r8_3d:" &
886  //" the size of the input data does not" &
887  //" match the size of the registered" &
888  //" cc-axis.")
889 
890  else
891  field_dimension_sizes(CCIDX) = size(fdata_3d,3)
892  endif
893  elseif (fdata_3d_axes(2) .eq. CCIDX) then
894  if (size(fdata_3d,2) .ne. size(fileObj%axes(CCIDX)%data)) then
895  call mpp_error(FATAL, &
896  "fms_io_unstructured_register_restart_field_r8_3d:" &
897  //" the size of the input data does not" &
898  //" match the size of the registered" &
899  //" cc-axis.")
900  endif
901  field_dimension_sizes(CCIDX) = size(fdata_3d,2)
902  if (fdata_3d_axes(3) .ne. ZIDX) then
903  call mpp_error(FATAL, &
904  "fms_io_unstructured_register_restart_field_r8_3d:" &
905  //" unsupported axis parameter for the third" &
906  //" dimension of the field.")
907  elseif (size(fdata_3d,3) .ne. size(fileObj%axes(ZIDX)%data)) then
908  call mpp_error(FATAL, &
909  "fms_io_unstructured_register_restart_field_r8_3d:" &
910  //" the size of the input data does not" &
911  //" match the size of the registered" &
912  //" z-axis.")
913  else
914  field_dimension_sizes(ZIDX) = size(fdata_3d,3)
915  endif
916  else
917  call mpp_error(FATAL, &
918  "fms_io_unstructured_register_restart_field_r8_3d:" &
919  //" unsupported axis parameter for the second" &
920  //" dimension of the field.")
921  endif
922 
923  !Add a field to a restart object (restart_file_type). Get the index of the
924  !inputted field in the fileObj%var array.
925  call fms_io_unstructured_setup_one_field(fileObj, &
926  filename, &
927  fieldname, &
928  fdata_3d_axes, &
929  field_dimension_sizes, &
930  index_field, &
931  domain, &
932  mandatory=mandatory, &
933  data_default=real(data_default), &
934  longname=longname, &
935  units=units, &
936  read_only=read_only, &
937  owns_data=restart_owns_data)
938 
939  !Point to the inputted data and return the "index_field" for the field.
940  fileObj%p3dr8(fileObj%var(index_field)%siz(4),index_field)%p => fdata_3d
941  fileObj%var(index_field)%ndim = 3
942  restart_index = index_field
943 
944  return
945 end function fms_io_unstructured_register_restart_field_r8_3d
946 #endif
947 
948 !------------------------------------------------------------------------------
949 !>Add an integer scalar field to a restart object (restart_file_type). Return
950 !!the index of the inputted field in the fileObj%var array.
951 function fms_io_unstructured_register_restart_field_i_0d(fileObj, &
952  filename, &
953  fieldname, &
954  fdata_0d, &
955  domain, &
956  mandatory, &
957  data_default, &
958  longname, &
959  units, &
960  read_only, &
961  restart_owns_data) &
962  result(restart_index)
963 
964  !Inputs/Outputs
965  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
966  character(len=*),intent(in) :: filename !<The name of a file.
967  character(len=*),intent(in) :: fieldname !<The name of a field.
968  integer,intent(in),target :: fdata_0d !<Some data.
969  type(domainUG),intent(in),target :: domain !<An unstructured mpp_domain.
970  logical,intent(in),optional :: mandatory !<Flag telling if the field is mandatory for the restart.
971  real,intent(in),optional :: data_default !<A default value for the data.
972  character(len=*),intent(in),optional :: longname !<A more descriptive name of the field.
973  character(len=*),intent(in),optional :: units !<Units for the field.
974  logical(INT_KIND),intent(in),optional :: read_only !<Tells whether or not the variable will be written to the restart file.
975  logical(INT_KIND),intent(in),optional :: restart_owns_data !<Tells if the data will be deallocated when the restart object is deallocated.
976  integer(INT_KIND) :: restart_index !<Index of the inputted field in the fileObj%var array.
977 
978  !Local variables
979  type(domainUG),pointer :: io_domain !<Pointer to an unstructured I/O domain.
980  integer(INT_KIND) :: io_domain_npes !<The number of ranks in the unstructured I/O domain pelist.
981  integer(INT_KIND),dimension(:),allocatable :: pelist !<A pelist.
982  integer,dimension(:),allocatable :: fdata_per_rank !<Array used to gather the scalar field values.
983  integer(INT_KIND) :: index_field !<Index of the inputted field in the fileObj%var array.
984  integer(INT_KIND),dimension(NIDX) :: field_dimension_sizes !<Array of dimension sizes for the field.
985  integer(INT_KIND),dimension(1) :: field_dimension_order !<Array telling the ordering of the dimensions for the field.
986 
987  !Make sure that the module has been initialized.
988  if (.not. module_is_initialized) then
989  call mpp_error(FATAL, &
990  "fms_io_unstructured_register_restart_field_i_0d:" &
991  //" you must first call fms_io_init")
992  endif
993 
994  !Make sure that the value of the scalar field is same across all ranks
995  !in an I/O domain pelist.
996  io_domain => null()
997  io_domain => mpp_get_UG_io_domain(domain)
998  io_domain_npes = mpp_get_UG_domain_npes(io_domain)
999  allocate(pelist(io_domain_npes))
1000  call mpp_get_UG_domain_pelist(io_domain, &
1001  pelist)
1002  allocate(fdata_per_rank(io_domain_npes))
1003  fdata_per_rank = 0.0
1004  call mpp_gather((/fdata_0d/), &
1005  fdata_per_rank, &
1006  pelist)
1007  if (mpp_pe() .eq. pelist(1)) then
1008  if (maxval(fdata_per_rank) .ne. fdata_0d .or. &
1009  minval(fdata_per_rank) .ne. fdata_0d) then
1010  call mpp_error(FATAL, &
1011  "fms_io_unstructured_register_restart_field_i_0d:" &
1012  //" the scalar field data is not consistent across" &
1013  //" all ranks in the I/O domain pelist.")
1014  endif
1015  endif
1016  io_domain => null()
1017  deallocate(pelist)
1018  deallocate(fdata_per_rank)
1019 
1020  !Set the dimension sizes for the field. These correspond to:
1021  !field_dimension_sizes(XIDX) = x-dimension size
1022  !field_dimension_sizes(YIDX) = y-dimension size
1023  !field_dimension_sizes(CIDX) = c-dimension size
1024  !field_dimension_sizes(ZIDX) = z-dimension size
1025  !field_dimension_sizes(HIDX) = h-dimension size
1026  !field_dimension_sizes(TIDX) = t-dimension size
1027  !field_dimension_sizes(UIDX) = u-dimension size
1028  !field_dimension_sizes(CCIDX) = cc-dimension size
1029  field_dimension_sizes = 1
1030 
1031  !Set the ordering of the dimensions for the field.
1032  field_dimension_order(1) = TIDX
1033 
1034  !Add a field to a restart object (restart_file_type). Get the index of the
1035  !inputted field in the fileObj%var array.
1036  call fms_io_unstructured_setup_one_field(fileObj, &
1037  filename, &
1038  fieldname, &
1039  field_dimension_order, &
1040  field_dimension_sizes, &
1041  index_field, &
1042  domain, &
1043  mandatory=mandatory, &
1044  data_default=data_default, &
1045  longname=longname, &
1046  units=units, &
1047  read_only=read_only, &
1048  owns_data=restart_owns_data)
1049 
1050  !Point to the inputted data and return the "index_field" for the field.
1051  fileObj%p0di(fileObj%var(index_field)%siz(4),index_field)%p => fdata_0d
1052  fileObj%var(index_field)%ndim = 0
1053  restart_index = index_field
1054 
1055  return
1056 end function fms_io_unstructured_register_restart_field_i_0d
1057 
1058 !------------------------------------------------------------------------------
1059 !>Add an integer 1D field to a restart object (restart_file_type), where the
1060 !!field is assumed to be along the unstructured axis. Return
1061 !!the index of the inputted field in the fileObj%var array.
1062 function fms_io_unstructured_register_restart_field_i_1d(fileObj, &
1063  filename, &
1064  fieldname, &
1065  fdata_1d, &
1066  fdata_1d_axes, &
1067  domain, &
1068  mandatory, &
1069  data_default, &
1070  longname, &
1071  units, &
1072  read_only, &
1073  restart_owns_data) &
1074  result(restart_index)
1075 
1076  !Inputs/Outputs
1077  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
1078  character(len=*),intent(in) :: filename !<The name of a file.
1079  character(len=*),intent(in) :: fieldname !<The name of a field.
1080  integer,dimension(:),intent(in),target :: fdata_1d !<Some data.
1081  integer(INT_KIND),dimension(1) :: fdata_1d_axes !<An array describing the axes for the data.
1082  type(domainUG),intent(in),target :: domain !<An unstructured mpp_domain.
1083  logical,intent(in),optional :: mandatory !<Flag telling if the field is mandatory for the restart.
1084  real,intent(in),optional :: data_default !<A default value for the data.
1085  character(len=*),intent(in),optional :: longname !<A more descriptive name of the field.
1086  character(len=*),intent(in),optional :: units !<Units for the field.
1087  logical(INT_KIND),intent(in),optional :: read_only !<Tells whether or not the variable will be written to the restart file.
1088  logical(INT_KIND),intent(in),optional :: restart_owns_data !<Tells if the data will be deallocated when the restart object is deallocated.
1089  integer(INT_KIND) :: restart_index !<Index of the inputted field in the fileObj%var array.
1090 
1091  !Local variables
1092  integer(INT_KIND) :: index_field !<Index of the inputted field in the fileObj%var array.
1093  integer(INT_KIND),dimension(NIDX) :: field_dimension_sizes !<Array of dimension sizes for the field.
1094 
1095  !Make sure that the module has been initialized.
1096  if (.not. module_is_initialized) then
1097  call mpp_error(FATAL, &
1098  "fms_io_unstructured_register_restart_field_i_1d:" &
1099  //" you must first call fms_io_init")
1100  endif
1101 
1102  !Make sure that at least one axis was registered to the restart object.
1103  if (.not. allocated(fileObj%axes)) then
1104  call mpp_error(FATAL, &
1105  "fms_io_unstructured_register_restart_field_i_1d:" &
1106  //" no axes have been registered for the restart" &
1107  //" object.")
1108  endif
1109 
1110  !Make sure that the first dimension of the field is a "compressed" axis,
1111  !and that it corresponds to an axis that has been registered to the
1112  !restart object.
1113  field_dimension_sizes = 1
1114  if (fdata_1d_axes(1) .eq. CIDX) then
1115  if (.not. allocated(fileObj%axes(CIDX)%idx)) then
1116  call mpp_error(FATAL, &
1117  "fms_io_unstructured_register_restart_field_i_1d:" &
1118  //" a compressed c-axis was not registered" &
1119  //" to the restart object.")
1120  endif
1121  if (size(fdata_1d,1) .ne. fileObj%axes(CIDX)%nelems_for_current_rank) then
1122  call mpp_error(FATAL, &
1123  "fms_io_unstructured_register_restart_field_i_1d:" &
1124  //" the size of the input data does not" &
1125  //" match the size of the registered" &
1126  //" compressed c-axis.")
1127  endif
1128  field_dimension_sizes(CIDX) = size(fdata_1d,1)
1129  elseif (fdata_1d_axes(1) .eq. HIDX) then
1130  if (.not. allocated(fileObj%axes(HIDX)%idx)) then
1131  call mpp_error(FATAL, &
1132  "fms_io_unstructured_register_restart_field_i_1d:" &
1133  //" a compressed h-axis was not registered" &
1134  //" to the restart object.")
1135  endif
1136  if (size(fdata_1d,1) .ne. fileObj%axes(HIDX)%nelems_for_current_rank) then
1137  call mpp_error(FATAL, &
1138  "fms_io_unstructured_register_restart_field_i_1d:" &
1139  //" the size of the input data does not" &
1140  //" match the size of the registered" &
1141  //" compressed h-axis.")
1142  endif
1143  field_dimension_sizes(HIDX) = size(fdata_1d,1)
1144  else
1145  call mpp_error(FATAL, &
1146  "fms_io_unstructured_register_restart_field_i_1d:" &
1147  //" One dimensional fields must be compressed.")
1148  endif
1149 
1150  !Add a field to a restart object (restart_file_type). Get the index of the
1151  !inputted field in the fileObj%var array.
1152  call fms_io_unstructured_setup_one_field(fileObj, &
1153  filename, &
1154  fieldname, &
1155  fdata_1d_axes, &
1156  field_dimension_sizes, &
1157  index_field, &
1158  domain, &
1159  mandatory=mandatory, &
1160  data_default=data_default, &
1161  longname=longname, &
1162  units=units, &
1163  read_only=read_only, &
1164  owns_data=restart_owns_data)
1165 
1166  !Point to the inputted data and return the "index_field" for the field.
1167  fileObj%p1di(fileObj%var(index_field)%siz(4),index_field)%p => fdata_1d
1168  fileObj%var(index_field)%ndim = 1
1169  restart_index = index_field
1170 
1171  return
1172 end function fms_io_unstructured_register_restart_field_i_1d
1173 
1174 !------------------------------------------------------------------------------
1175 !>Add an integer 2D field to a restart object (restart_file_type), where the
1176 !!field's 1st axis assumed to be along the unstructured axis and the field's
1177 !!2nd axis is assumed to be along the z-axis. Return the index of the
1178 !!inputted field in the fileObj%var array.
1179 function fms_io_unstructured_register_restart_field_i_2d(fileObj, &
1180  filename, &
1181  fieldname, &
1182  fdata_2d, &
1183  fdata_2d_axes, &
1184  domain, &
1185  mandatory, &
1186  data_default, &
1187  longname, &
1188  units, &
1189  read_only, &
1190  restart_owns_data) &
1191  result(restart_index)
1192 
1193  !Inputs/Outputs
1194  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
1195  character(len=*),intent(in) :: filename !<The name of a file.
1196  character(len=*),intent(in) :: fieldname !<The name of a field.
1197  integer,dimension(:,:),intent(in),target :: fdata_2d !<Some data.
1198  integer(INT_KIND),dimension(2) :: fdata_2d_axes !<An array describing the axes for the data.
1199  type(domainUG),intent(in),target :: domain !<An unstructured mpp_domain.
1200  logical,intent(in),optional :: mandatory !<Flag telling if the field is mandatory for the restart.
1201  real,intent(in),optional :: data_default !<A default value for the data.
1202  character(len=*),intent(in),optional :: longname !<A more descriptive name of the field.
1203  character(len=*),intent(in),optional :: units !<Units for the field.
1204  logical(INT_KIND),intent(in),optional :: read_only !<Tells whether or not the variable will be written to the restart file.
1205  logical(INT_KIND),intent(in),optional :: restart_owns_data !<Tells if the data will be deallocated when the restart object is deallocated.
1206  integer(INT_KIND) :: restart_index !<Index of the inputted field in the fileObj%var array.
1207 
1208  !Local variables
1209  integer(INT_KIND) :: index_field !<Index of the inputted field in the fileObj%var array.
1210  integer(INT_KIND),dimension(NIDX) :: field_dimension_sizes !<Array of dimension sizes for the field.
1211 
1212  !Make sure that the module has been initialized.
1213  if (.not. module_is_initialized) then
1214  call mpp_error(FATAL, &
1215  "fms_io_unstructured_register_restart_field_i_2d:" &
1216  //" you must first call fms_io_init")
1217  endif
1218 
1219  !Make sure that at least one axis was registered to the restart object.
1220  if (.not. allocated(fileObj%axes)) then
1221  call mpp_error(FATAL, &
1222  "fms_io_unstructured_register_restart_field_i_2d:" &
1223  //" no axes have been registered for the restart" &
1224  //" object.")
1225  endif
1226 
1227  !Make sure that the first dimension of the field is a "compressed" axis,
1228  !and that it corresponds to an axis that has been registered to the
1229  !restart object.
1230  field_dimension_sizes = 1
1231  if (fdata_2d_axes(1) .eq. CIDX) then
1232  if (.not. allocated(fileObj%axes(CIDX)%idx)) then
1233  call mpp_error(FATAL, &
1234  "fms_io_unstructured_register_restart_field_i_2d:" &
1235  //" a compressed c-axis was not registered" &
1236  //" to the restart object.")
1237  endif
1238  if (size(fdata_2d,1) .ne. fileObj%axes(CIDX)%nelems_for_current_rank) then
1239  call mpp_error(FATAL, &
1240  "fms_io_unstructured_register_restart_field_i_2d:" &
1241  //" the size of the input data does not" &
1242  //" match the size of the registered" &
1243  //" compressed c-axis.")
1244  endif
1245  field_dimension_sizes(CIDX) = size(fdata_2d,1)
1246  elseif (fdata_2d_axes(1) .eq. HIDX) then
1247  if (.not. allocated(fileObj%axes(HIDX)%idx)) then
1248  call mpp_error(FATAL, &
1249  "fms_io_unstructured_register_restart_field_i_2d:" &
1250  //" a compressed h-axis was not registered" &
1251  //" to the restart object.")
1252  endif
1253  if (size(fdata_2d,1) .ne. fileObj%axes(HIDX)%nelems_for_current_rank) then
1254  call mpp_error(FATAL, &
1255  "fms_io_unstructured_register_restart_field_i_2d:" &
1256  //" the size of the input data does not" &
1257  //" match the size of the registered" &
1258  //" compressed h-axis.")
1259  endif
1260  field_dimension_sizes(HIDX) = size(fdata_2d,1)
1261  else
1262  call mpp_error(FATAL, &
1263  "fms_io_unstructured_register_restart_field_i_2d:" &
1264  //" The first dimension of the field must be a" &
1265  //" compressed dimension.")
1266  endif
1267 
1268  !Make sure that the second dimension of the inputted field corresponds to
1269  !either a registered z- or cc-axis.
1270  if (fdata_2d_axes(2) .eq. ZIDX) then
1271  if (.not. associated(fileObj%axes(ZIDX)%data)) then
1272  call mpp_error(FATAL, &
1273  "fms_io_unstructured_register_restart_field_i_2d:" &
1274  //" a z-axis was not registered to the" &
1275  //" restart object.")
1276  endif
1277  if (size(fdata_2d,2) .ne. size(fileObj%axes(ZIDX)%data)) then
1278  call mpp_error(FATAL, &
1279  "fms_io_unstructured_register_restart_field_i_2d:" &
1280  //" the size of the input data does not" &
1281  //" match the size of the registered" &
1282  //" z-axis.")
1283  endif
1284  field_dimension_sizes(ZIDX) = size(fdata_2d,2)
1285  elseif (fdata_2d_axes(2) .eq. CCIDX) then
1286  if (.not. associated(fileObj%axes(CCIDX)%data)) then
1287  call mpp_error(FATAL, &
1288  "fms_io_unstructured_register_restart_field_i_2d:" &
1289  //" a cc-axis was not registered to the" &
1290  //" restart object.")
1291  endif
1292  if (size(fdata_2d,2) .ne. size(fileObj%axes(CCIDX)%data)) then
1293  call mpp_error(FATAL, &
1294  "fms_io_unstructured_register_restart_field_i_2d:" &
1295  //" the size of the input data does not" &
1296  //" match the size of the registered" &
1297  //" cc-axis.")
1298  endif
1299  field_dimension_sizes(CCIDX) = size(fdata_2d,2)
1300  else
1301  call mpp_error(FATAL, &
1302  "fms_io_unstructured_register_restart_field_i_2d:" &
1303  //" unsupported axis parameter for the second" &
1304  //" dimension of the field.")
1305  endif
1306 
1307  !Add a field to a restart object (restart_file_type). Get the index of the
1308  !inputted field in the fileObj%var array.
1309  call fms_io_unstructured_setup_one_field(fileObj, &
1310  filename, &
1311  fieldname, &
1312  fdata_2d_axes, &
1313  field_dimension_sizes, &
1314  index_field, &
1315  domain, &
1316  mandatory=mandatory, &
1317  data_default=data_default, &
1318  longname=longname, &
1319  units=units, &
1320  read_only=read_only, &
1321  owns_data=restart_owns_data)
1322 
1323  !Point to the inputted data and return the "index_field" for the field.
1324  fileObj%p2di(fileObj%var(index_field)%siz(4),index_field)%p => fdata_2d
1325  fileObj%var(index_field)%ndim = 2
1326  restart_index = index_field
1327 
1328  return
1329 end function fms_io_unstructured_register_restart_field_i_2d
1330 
1331 !------------------------------------------------------------------------------
1332 
1333 !----------
will
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version will
Definition: mpp_transmit_mpi.h:166
time_interp_external_mod::field
type(ext_fieldtype), dimension(:), pointer, save, private field
Definition: time_interp_external.F90:137
odps_coordinatemapping::cc
real(fp), parameter cc
Definition: ODPS_CoordinateMapping.f90:51
integer
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_ ::wbuffer3D(size(wbuffer, 1), size(wbuffer, 2), 1) MPP_TYPE_ ::ebuffer3D(size(ebuffer, 1), size(ebuffer, 2), 1) MPP_TYPE_ ::sbuffer3D(size(sbuffer, 1), size(sbuffer, 2), 1) MPP_TYPE_ ::nbuffer3D(size(nbuffer, 1), size(nbuffer, 2), 1) pointer(ptr, field3D) pointer(ptr_w, wbuffer3D) pointer(ptr_e, ebuffer3D) pointer(ptr_s, sbuffer3D) pointer(ptr_n, nbuffer3D) ptr=LOC(field) ptr_w=LOC(wbuffer) ptr_e=LOC(ebuffer) ptr_s=LOC(sbuffer) ptr_n=LOC(nbuffer) call mpp_update_nest_fine(field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, &flags, complete, position, extra_halo, name, tile_count) returnend subroutine MPP_UPDATE_NEST_FINE_2D_subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::d_type type(nestSpec), pointer ::update=> set_mismatch integer ::tile update_position nbuffersz l_size integer
Definition: mpp_update_nest_domains.h:79
allocatable
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_WRITE_UNLIMITED_AXIS_1D_(unit, field, domain, data, nelems_io) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:) integer, intent(in) ::nelems_io(:) ! number of compressed elements from each ! member of the io_domain. It MUST have the ! same order as the io_domain pelist. integer, allocatable ::pelist(:) integer ::i, j, nelems, npes type(domain2d), pointer ::io_domain=> allocatable
Definition: mpp_write_unlimited_axis.h:30
fv3jedi_increment_mod::copy
subroutine, public copy(self, rhs)
Definition: fv3jedi_increment_mod.f90:254
end
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT end
Definition: mpp_transmit_mpi.h:153
AS
CREATE TABLE desc AS(andate YYYYMMDD, antime HHMMSS, hdr @LINK,)
field_manager_mod::fields
type(field_mgr_type), dimension(max_fields), private fields
Definition: field_manager.F90:536
diag_integral_mod::nd
integer nd
Definition: diag_integral.F90:288
interpolator_mod::units
character(len=32) units
No description.
Definition: interpolator.F90:329
diag_axis_mod::axes
type(diag_axis_type), dimension(:), allocatable, save axes
Definition: diag_axis.F90:80
gsw_mod_check_data::p
real(r8), dimension(cast_m, cast_n) p
Definition: gsw_mod_check_data.f90:247
interpolator_mod::name
character(len=32) name
Definition: interpolator.F90:329
if
l_size ! loop over number of fields ke do je do ie to je n if(.NOT. d_comm%R_do_buf(list)) cycle from_pe
amip_interp_mod::module_is_initialized
logical module_is_initialized
Definition: amip_interp.F90:272
diag_integral_mod::version
character(len=128) version
Definition: diag_integral.F90:121
is
l_size ! loop over number of fields ke do je do ie to is
Definition: mpp_do_redistribute.h:72
odps_coordinatemapping::c
real(fp), parameter c
Definition: ODPS_CoordinateMapping.f90:49
c2f.type
type
Definition: c2f.py:15
mpp_error
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call mpp_error(FATAL, 'MPP_TRANSMIT:you cannot transmit to ANY_PE using MPI.') else if(to_pe.NE.NULL_PE) then !no other valid cases except NULL_PE call mpp_error(FATAL
accoeff_define::one
real(double), parameter one
Definition: ACCoeff_Define.f90:69
type_distribution::received
logical function received(this, seqno)
Definition: m_distribution.f90:72
interpolator_mod::len
integer len
Definition: interpolator.F90:321
size
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this ! since that attempts to gather all data on PE size(field%axes(:)) axsiz(i)
a
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version and mpp_transmit will remain !backward compatible intent(inout) a
Definition: mpp_transmit_mpi.h:178
dimension
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_ ::wbuffer3D(size(wbuffer, 1), size(wbuffer, 2), 1) MPP_TYPE_ ::ebuffer3D(size(ebuffer, 1), size(ebuffer, 2), 1) MPP_TYPE_ ::sbuffer3D(size(sbuffer, 1), size(sbuffer, 2), 1) MPP_TYPE_ ::nbuffer3D(size(nbuffer, 1), size(nbuffer, 2), 1) pointer(ptr, field3D) pointer(ptr_w, wbuffer3D) pointer(ptr_e, ebuffer3D) pointer(ptr_s, sbuffer3D) pointer(ptr_n, nbuffer3D) ptr=LOC(field) ptr_w=LOC(wbuffer) ptr_e=LOC(ebuffer) ptr_s=LOC(sbuffer) ptr_n=LOC(nbuffer) call mpp_update_nest_fine(field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, &flags, complete, position, extra_halo, name, tile_count) returnend subroutine MPP_UPDATE_NEST_FINE_2D_subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::d_type type(nestSpec), pointer ::update=> dimension(MAX_DOMAIN_FIELDS)
gsw_mod_check_data::t
real(r8), dimension(cast_m, cast_n) t
Definition: gsw_mod_check_data.f90:224
station_data_mod::pelist
integer, dimension(:), allocatable pelist
Definition: station_data.F90:293
not
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If not
Definition: drifters_compute_k.h:5
INT_KIND
#define INT_KIND
DOUBLE_KIND
#define DOUBLE_KIND
xgrid_mod::some
subroutine, public some(xmap, some_arr, grid_id)
Definition: xgrid.F90:3421
c2f.module
module
Definition: c2f.py:21
tools_repro::eq
logical function, public eq(x, y)
Definition: tools_repro.F90:28
interpolator_mod::ndim
integer ndim
No description.
Definition: interpolator.F90:311