FV3 Bundle
fms_io_unstructured_register_restart_axis.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 !>Store a real axis (x,y,z,...) in a restart object assoicated with an
24 !!unstructured mpp domain.
25 subroutine fms_io_unstructured_register_restart_axis_r1D(fileObj, &
26  filename, &
27  fieldname, &
28  fdata, &
29  cartesian, &
30  domain, &
31  units, &
32  longname, &
33  sense, &
34  fmin, &
35  calendar)
36  !Inputs/Outputs
37  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
38  character(len=*),intent(in) :: filename !<A name of a file.
39  character(len=*),intent(in) :: fieldname !<A name for the axis field.
40  real,dimension(:),intent(in),target :: fdata !<Data for the axis.
41  character(len=*),intent(in) :: cartesian !<String indicating which cartesian axis this is (i.e. X, Y, Z).
42  type(domainUG),intent(in),target :: domain !<An unustructured mpp domain.
43  character(len=*),intent(in),optional :: units !<Units for the axis.
44  character(len=*),intent(in),optional :: longname !<A more descriptive name for the axis.
45  integer(INT_KIND),intent(in),optional :: sense !<Positive direction.
46  real,intent(in),optional :: fmin !<Minimum value for this axis.
47  character(len=*),intent(in),optional :: calendar !<Type of calendar (only for time axis.)
48 
49  !Local variables
50  integer(INT_KIND) :: input_filename_length !<The length of the trimmed input filename.
51  character(len=256) :: tmp_filename !<A character buffer used to store various file names.
52  character(len=256) :: filename_suffix !<A string appended to the end of the inputted file name.
53  character(len=256) :: mosaic_filename !<The filename returned by the get_mosaic_tile_file_ug routine.
54  integer(INT_KIND) :: axis_index !<Index of the inputted axis in the fileObj%axes array.
55  type(domainUG),pointer :: io_domain !<Pointer to an unstructured I/O domain.
56  integer(INT_KIND) :: io_domain_npes !<The total number of ranks in an I/O domain pelist.
57  integer(INT_KIND),dimension(:),allocatable :: pelist !<A pelist.
58  integer(INT_KIND),dimension(:),allocatable :: fdata_sizes !<Size of the axis data for each rank in the I/O domain pelist.
59 
60  !Make sure that the module is initialized.
61  if (.not. module_is_initialized) then
62  call mpp_error(FATAL, &
63  "fms_io_unstructured_register_restart_axis_r1D:" &
64  //" you must first to call fms_io_init.")
65  endif
66 
67  !All axes must be registered before any fields. Make sure that no
68  !fields have been registered to the restart object.
69  if (associated(fileObj%var)) then
70  call mpp_error(FATAL, &
71  "fms_io_unstructured_register_restart_axis_r1D: " &
72  //" you cannot register any fields before an axis.")
73  endif
74 
75  !Use this code to make the filename consistent with the
76  !fms_io_unstructured_setup_one_field routine.
77  input_filename_length = len_trim(filename)
78  if (input_filename_length .gt. 128) then
79  call mpp_error(FATAL, &
80  "fms_io_unstructured_register_restart_axis_r1D:" &
81  //" the inputted file name is longer than 128" &
82  //" characters.")
83  endif
84  if (filename(input_filename_length-2:input_filename_length) .eq. ".nc") then
85  tmp_filename = filename(1:input_filename_length-3)
86  else
87  tmp_filename = filename(1:input_filename_length)
88  endif
89  filename_suffix = ""
90  if (len_trim(filename_appendix) .gt. 0) then
91  filename_suffix = trim(filename_appendix)
92  endif
93  if (len_trim(filename_suffix) .gt. 0) then
94  tmp_filename = trim(tmp_filename)//"."//trim(filename_suffix)
95  endif
96  call get_mosaic_tile_file_ug(tmp_filename, &
97  mosaic_filename, &
98  domain)
99 
100  !Make sure that the correct file name was passed in, or set the filename
101  !if this is the first axis/field registered to the restart object.
102  if (.not. allocated(fileObj%axes)) then
103  fileObj%name = trim(mosaic_filename)
104  else
105  if (trim(mosaic_filename) .ne. trim(fileObj%name)) then
106  call mpp_error(FATAL, &
107  "fms_io_unstructured_register_restart_axis_r1D:" &
108  //" the inputted file name does not match the" &
109  //" existing file name for this restart object.")
110  endif
111  endif
112 
113  !If this is the first axis registered for the restart object, then
114  !allocate the fileObj%axes array. The size of the fileObj%axes array
115  !is determined by the NIDX module parameter.
116  if (.not. allocated(fileObj%axes)) then
117  allocate(fileObj%axes(NIDX))
118  endif
119 
120  !Determine the index of the inputted axis in the fileObj%axes array from
121  !the inputted cartesian string.
122  select case (trim(cartesian))
123  case ("X")
124  axis_index = XIDX
125  case ("Y")
126  axis_index = YIDX
127  case ("Z")
128  axis_index = ZIDX
129  case ("T")
130  axis_index = TIDX
131  case ("CC")
132  axis_index = CCIDX
133  case default
134  call mpp_error(FATAL, &
135  "fms_io_unstructured_register_restart_axis_r1D:" &
136  //" an invalid cartesian string was passed in.")
137  end select
138 
139  !Make sure that data has not already been registered for the inputted
140  !axis.
141  if (associated(fileObj%axes(axis_index)%data)) then
142  call mpp_error(FATAL, &
143  "fms_io_unstructured_register_restart_axis_r1D:" &
144  //" the "//trim(cartesian)//" axis for this restart" &
145  //" object has already been defined.")
146  endif
147 
148  !Make sure that the axis size is consistent for all ranks on the
149  !unstructured I/O domain pelist.
150  io_domain => null()
151  io_domain => mpp_get_UG_io_domain(domain)
152  io_domain_npes = mpp_get_UG_domain_npes(io_domain)
153  allocate(pelist(io_domain_npes))
154  call mpp_get_UG_domain_pelist(io_domain, &
155  pelist)
156  allocate(fdata_sizes(io_domain_npes))
157  fdata_sizes = 0
158  call mpp_gather((/size(fdata)/), &
159  fdata_sizes, &
160  pelist)
161  if (mpp_pe() .eq. pelist(1)) then
162  if (maxval(fdata_sizes) .ne. size(fdata) .or. &
163  minval(fdata_sizes) .ne. size(fdata)) then
164  call mpp_error(FATAL, &
165  "fms_io_unstructured_register_restart_axis_r1D:" &
166  //" the "//trim(cartesian)//" axis must be the" &
167  //" the same size for all ranks in the" &
168  //" unstructured I/O domain pelist.")
169  endif
170  endif
171  io_domain => null()
172  deallocate(pelist)
173  deallocate(fdata_sizes)
174 
175  !Set the name of the axis.
176  fileObj%axes(axis_index)%name = trim(fieldname)
177 
178  !Point to the inputted unstructured domain for the axis.
179  fileObj%axes(axis_index)%domain_ug => domain
180 
181  !Point to the inputted axis data.
182  fileObj%axes(axis_index)%data => fdata
183 
184  !Store the inputted cartesian string. (Why?)
185  fileObj%axes(axis_index)%cartesian = trim(cartesian)
186 
187  !Set the dimension length for the axis to -1 to signify that this is
188  !not a "compressed" axis.
189  fileObj%axes(axis_index)%dimlen = -1
190 
191  !Store the units for the axis.
192  if (present(units)) then
193  fileObj%axes(axis_index)%units = trim(units)
194  else
195  fileObj%axes(axis_index)%units = ""
196  endif
197 
198  !Store the longname for the axis.
199  if (present(longname)) then
200  fileObj%axes(axis_index)%longname = trim(longname)
201  else
202  fileObj%axes(axis_index)%longname = ""
203  endif
204 
205  !Store the "sense" for the axis. Inputs must be for the z-dimension.
206  if (present(sense)) then
207  if (axis_index .ne. ZIDX) then
208  call mpp_error(FATAL, &
209  "fms_io_unstructured_register_restart_axis_r1D:" &
210  //" sense may only be defined for the z-axis.")
211  endif
212  if (abs(sense) .ne. 1) then
213  call mpp_error(FATAL, &
214  "fms_io_unstructured_register_restart_axis_r1D:" &
215  //" sense may only have the values +/- 1")
216  endif
217  fileObj%axes(axis_index)%sense = sense
218  else
219  fileObj%axes(axis_index)%sense = 0
220  endif
221 
222  !Store the minimum value allowed for the axis.
223  if (present(fmin)) then
224  fileObj%axes(axis_index)%min = fmin
225  else
226  fileObj%axes(axis_index)%min = 0
227  endif
228 
229  !Store the calendar for the axis. This is only done for the time dimension.
230  if (axis_index .eq. TIDX) then
231  fileObj%axes(axis_index)%calendar = trim(calendar)
232  endif
233 
234  return
235 end subroutine fms_io_unstructured_register_restart_axis_r1D
236 
237 !------------------------------------------------------------------------------
238 !>Store an integer "compressed" axis in a restart object assoicated with an
239 !!unstructured mpp domain.
240 subroutine fms_io_unstructured_register_restart_axis_i1D(fileObj, &
241  filename, &
242  fieldname, &
243  fdata, &
244  compressed, &
245  compressed_axis, &
246  dimlen, &
247  domain, &
248  dimlen_name, &
249  dimlen_lname, &
250  units, &
251  longname, &
252  imin)
253  !Inputs/Outputs
254  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
255  character(len=*),intent(in) :: filename !<A name of a file.
256  character(len=*),intent(in) :: fieldname !<A name for the axis field.
257  integer(INT_KIND),dimension(:),intent(in),target :: fdata !<Data for the axis.
258  character(len=*),intent(in) :: compressed !<"Compressed" string (???)
259  character(len=*),intent(in) :: compressed_axis !<"Compressed" axis string.
260  integer(INT_KIND),intent(in) :: dimlen !<Length of the compressed dimension.
261  type(domainUG),intent(in),target :: domain !<An unustructured mpp domain.
262  character(len=*),intent(in),optional :: dimlen_name !<(???)
263  character(len=*),intent(in),optional :: dimlen_lname !<(???)
264  character(len=*),intent(in),optional :: units !<Units for the axis.
265  character(len=*),intent(in),optional :: longname !<A more descriptive name for the axis.
266  integer(INT_KIND),intent(in),optional :: imin !<Minium value for the dimension.
267 
268  !Local variables
269  integer(INT_KIND) :: input_filename_length !<The length of the trimmed input filename.
270  character(len=256) :: tmp_filename !<A character buffer used to store various file names.
271  character(len=256) :: filename_suffix !<A string appended to the end of the inputted file name.
272  character(len=256) :: mosaic_filename !<The filename returned by the get_mosaic_tile_file_ug routine.
273  integer(INT_KIND) :: axis_index !<Index of the inputted axis in the fileObj%axes array.
274  type(domainUG),pointer :: io_domain !<Pointer to an unstructured I/O domain.
275  integer(INT_KIND) :: io_domain_npes !<The total number of ranks in an I/O domain pelist.
276  integer(INT_KIND),dimension(:),allocatable :: pelist !<A pelist.
277 
278  !Make sure that the module is initialized.
279  if (.not. module_is_initialized) then
280  call mpp_error(FATAL, &
281  "fms_io_unstructured_register_restart_axis_i1D:" &
282  //" you must first to call fms_io_init.")
283  endif
284 
285  !All axes must be registered before any fields. Make sure that no
286  !fields have been registered to the restart object.
287  if (associated(fileObj%var)) then
288  call mpp_error(FATAL, &
289  "fms_io_unstructured_register_restart_axis_i1D:" &
290  //" you cannot register any fields before an axis.")
291  endif
292 
293  !Use this code to make the filename consistent with the
294  !fms_io_unstructured_setup_one_field routine.
295  input_filename_length = len_trim(filename)
296  if (input_filename_length .gt. 128) then
297  call mpp_error(FATAL, &
298  "fms_io_unstructured_register_restart_axis_i1D:" &
299  //" the inputted file name is longer than 128" &
300  //" characters.")
301  endif
302  if (filename(input_filename_length-2:input_filename_length) .eq. ".nc") then
303  tmp_filename = filename(1:input_filename_length-3)
304  else
305  tmp_filename = filename(1:input_filename_length)
306  endif
307  filename_suffix = ""
308  if (len_trim(filename_appendix) .gt. 0) then
309  filename_suffix = trim(filename_appendix)
310  endif
311  if (len_trim(filename_suffix) .gt. 0) then
312  tmp_filename = trim(tmp_filename)//"."//trim(filename_suffix)
313  endif
314  call get_mosaic_tile_file_ug(tmp_filename, &
315  mosaic_filename, &
316  domain)
317 
318  !Make sure that the correct file name was passed in, or set the filename
319  !if this is the first axis/field registered to the restart object.
320  if (.not. allocated(fileObj%axes)) then
321  fileObj%name = trim(mosaic_filename)
322  else
323  if (trim(mosaic_filename) .ne. trim(fileObj%name)) then
324  call mpp_error(FATAL, &
325  "fms_io_unstructured_register_restart_axis_i1D:" &
326  //" the inputted file name does not match the" &
327  //" existing file name for this restart object.")
328  endif
329  endif
330 
331  !If this is the first axis registered for the restart object, then
332  !allocate the fileObj%axes array. The size of the fileObj%axes array
333  !is determined by the NIDX module parameter.
334  if (.not. allocated(fileObj%axes)) then
335  allocate(fileObj%axes(NIDX))
336  endif
337 
338  !Get the index of the inputted axis in the fileObj%axes array from the
339  !inputted compressed_axis string.
340  select case (trim(compressed_axis))
341  case ("C")
342  axis_index = CIDX
343  case ("H")
344  axis_index = HIDX
345  case default
346  call mpp_error(FATAL, &
347  "fms_io_unstructured_register_restart_axis_i1D:" &
348  //" invalid compressed_axis string was passed in.")
349  end select
350 
351  !Make sure that data has not already been registered for the inputted axis.
352  if (allocated(fileObj%axes(axis_index)%idx)) then
353  call mpp_error(FATAL, &
354  "fms_io_unstructured_register_restart_axis_i1D:" &
355  //" the "//trim(compressed_axis)//" axis for this" &
356  //" restart object has already been defined.")
357  endif
358 
359  !Set the name of the axis.
360  fileObj%axes(axis_index)%name = trim(fieldname)
361 
362  !Point to the inputted unstructured domain.
363  fileObj%axes(axis_index)%domain_ug => domain
364 
365  !Initialize the number of data elements each rank in an unstructured I/O
366  !domain is responsible for.
367  io_domain => null()
368  io_domain => mpp_get_UG_io_domain(domain)
369  io_domain_npes = mpp_get_UG_domain_npes(io_domain)
370  allocate(fileObj%axes(axis_index)%nelems(io_domain_npes))
371  fileObj%axes(axis_index)%nelems = 0
372  fileObj%axes(axis_index)%nelems_for_current_rank = size(fdata)
373 
374  !Gather the sizes of the inputted data arrays for each rank onto the root
375  !rank of the I/O domain pelist.
376  allocate(pelist(io_domain_npes))
377  call mpp_get_UG_domain_pelist(io_domain, &
378  pelist)
379  call mpp_gather((/size(fdata)/), &
380  fileObj%axes(axis_index)%nelems, &
381  pelist)
382 
383  !Gather the inputted data from each rank onto the root rank of the I/O
384  !domain pelist.
385  if (mpp_pe() .eq. pelist(1)) then
386  allocate(fileObj%axes(axis_index)%idx(sum(fileObj%axes(axis_index)%nelems)))
387  else
388  !This array for a non-root rank on the I/O domain pelist should never
389  !be used, but is allocated to signify that this axis is defined for
390  !this restart object.
391  allocate(fileObj%axes(axis_index)%idx(1))
392  fileObj%axes(axis_index)%idx = 0
393  endif
394  call mpp_gather(fdata, &
395  size(fdata), &
396  fileObj%axes(axis_index)%idx, &
397  fileObj%axes(axis_index)%nelems, &
398  pelist)
399 
400  !Nullify local pointers and deallocate local allocatables.
401  io_domain => null()
402  deallocate(pelist)
403 
404  !Set the "compressed" string for the axis.
405  fileObj%axes(axis_index)%compressed = trim(compressed)
406 
407  !Set the dimension length for the axis.
408  fileObj%axes(axis_index)%dimlen = dimlen
409 
410  !Set the dimlen_name (???) for the axis.
411  if (present(dimlen_name)) then
412  fileObj%axes(axis_index)%dimlen_name = trim(dimlen_name)
413  else
414  fileObj%axes(axis_index)%dimlen_name = ""
415  endif
416 
417  !Set the dimlen_lname (???) for the axis.
418  if (present(dimlen_lname)) then
419  fileObj%axes(axis_index)%dimlen_lname = trim(dimlen_lname)
420  else
421  fileObj%axes(axis_index)%dimlen_lname = ""
422  endif
423 
424  !Set the units for the axis.
425  if (present(units)) then
426  fileObj%axes(axis_index)%units = trim(units)
427  else
428  fileObj%axes(axis_index)%units = ""
429  endif
430 
431  !Set the longname for the axis.
432  if (present(longname)) then
433  fileObj%axes(axis_index)%longname = trim(longname)
434  else
435  fileObj%axes(axis_index)%longname = ""
436  endif
437 
438  !Set the minimum value for the axis.
439  if (present(imin)) then
440  fileObj%axes(axis_index)%imin = imin
441  else
442  fileObj%axes(axis_index)%imin = 0
443  endif
444 
445  return
446 end subroutine fms_io_unstructured_register_restart_axis_i1D
447 
448 !------------------------------------------------------------------------------
449 !>Store an unlimited axis in a restart object assoicated with an unstructured
450 !!mpp domain.
451 subroutine fms_io_unstructured_register_restart_axis_u(fileObj, &
452  filename, &
453  fieldname, &
454  nelems, &
455  domain, &
456  units, &
457  longname)
458  !Inputs/Outputs
459  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
460  character(len=*),intent(in) :: filename !<A name of a file.
461  character(len=*),intent(in) :: fieldname !<A name for the axis field.
462  integer(INT_KIND),intent(in) :: nelems !<Number of elements on the axis for the current rank.
463  type(domainUG),intent(in),target :: domain !<An unustructured mpp domain.
464  character(len=*),intent(in),optional :: units !<Units for the axis.
465  character(len=*),intent(in),optional :: longname !<A more descriptive name for the axis.
466 
467  !Local variables
468  integer(INT_KIND) :: input_filename_length !<The length of the trimmed input filename.
469  character(len=256) :: tmp_filename !<A character buffer used to store various file names.
470  character(len=256) :: filename_suffix !<A string appended to the end of the inputted file name.
471  character(len=256) :: mosaic_filename !<The filename returned by the get_mosaic_tile_file_ug routine.
472  integer(INT_KIND) :: axis_index !<Index of the inputted axis in the fileObj%axes array.
473  type(domainUG),pointer :: io_domain !<Pointer to an unstructured I/O domain.
474  integer(INT_KIND) :: io_domain_npes !<The total number of ranks in an I/O domain pelist.
475  integer(INT_KIND),dimension(:),allocatable :: pelist !<A pelist.
476 
477  !Make sure that the module is initialized.
478  if (.not. module_is_initialized) then
479  call mpp_error(FATAL, &
480  "fms_io_unstructured_register_restart_axis_u:" &
481  //" you must first to call fms_io_init.")
482  endif
483 
484  !All axes must be registered before any fields. Make sure that no
485  !fields have been registered to the restart object.
486  if (associated(fileObj%var)) then
487  call mpp_error(FATAL, &
488  "fms_io_unstructured_register_restart_axis_u:" &
489  //" you cannot register any fields before an axis.")
490  endif
491 
492  !Use this code to make the filename consistent with the
493  !fms_io_unstructured_setup_one_field routine.
494  input_filename_length = len_trim(filename)
495  if (input_filename_length .gt. 128) then
496  call mpp_error(FATAL, &
497  "fms_io_unstructured_register_restart_axis_u:" &
498  //" the inputted file name is longer than 128" &
499  //" characters.")
500  endif
501  if (filename(input_filename_length-2:input_filename_length) .eq. ".nc") then
502  tmp_filename = filename(1:input_filename_length-3)
503  else
504  tmp_filename = filename(1:input_filename_length)
505  endif
506  filename_suffix = ""
507  if (len_trim(filename_appendix) .gt. 0) then
508  filename_suffix = trim(filename_appendix)
509  endif
510  if (len_trim(filename_suffix) .gt. 0) then
511  tmp_filename = trim(tmp_filename)//"."//trim(filename_suffix)
512  endif
513  call get_mosaic_tile_file_ug(tmp_filename, &
514  mosaic_filename, &
515  domain)
516 
517  !Make sure that the correct file name was passed in, or set the filename
518  !if this is the first axis/field registered to the restart object.
519  if (.not. allocated(fileObj%axes)) then
520  fileObj%name = trim(mosaic_filename)
521  else
522  if (trim(mosaic_filename) .ne. trim(fileObj%name)) then
523  call mpp_error(FATAL, &
524  "fms_io_unstructured_register_restart_axis_u:" &
525  //" the inputted file name does not match the" &
526  //" existing file name for this restart object.")
527  endif
528  endif
529 
530  !If this is the first axis registered for the restart object, then
531  !allocate the fileObj%axes array. The size of the fileObj%axes array
532  !is determined by the NIDX module parameter.
533  if (.not. allocated(fileObj%axes)) then
534  allocate(fileObj%axes(NIDX))
535  endif
536 
537  !Get the index of the inputted axis in the fileObj%axes array.
538  axis_index = UIDX
539 
540  !Make sure that data has not already been registered for the inputted axis.
541  if (allocated(fileObj%axes(axis_index)%idx)) then
542  call mpp_error(FATAL, &
543  "fms_io_unstructured_register_restart_axis_u:" &
544  //" the unlimited axis for this restart object" &
545  //" has already been defined.")
546  endif
547 
548  !Set the name of the axis.
549  fileObj%axes(axis_index)%name = trim(fieldname)
550 
551  !Point to the inputted unstructured domain.
552  fileObj%axes(axis_index)%domain_ug => domain
553 
554  !Initialize the number of data elements each rank in an unstructured I/O
555  !domain is responsible for.
556  io_domain => null()
557  io_domain => mpp_get_UG_io_domain(domain)
558  io_domain_npes = mpp_get_UG_domain_npes(io_domain)
559  allocate(fileObj%axes(axis_index)%nelems(io_domain_npes))
560  fileObj%axes(axis_index)%nelems = 0
561 
562  !Gather the inputted number of elements each rank is responsible for onto
563  !the root rank of the I/O domain pelist.
564  allocate(pelist(io_domain_npes))
565  call mpp_get_UG_domain_pelist(io_domain, &
566  pelist)
567  call mpp_gather((/nelems/), &
568  fileObj%axes(axis_index)%nelems, &
569  pelist)
570 
571  !Nullify local pointers and deallocate local allocatables.
572  io_domain => null()
573  deallocate(pelist)
574 
575  !Set the units for the axis.
576  if (present(units)) then
577  fileObj%axes(axis_index)%units = trim(units)
578  else
579  fileObj%axes(axis_index)%units = ""
580  endif
581 
582  !Set the longname for the axis.
583  if (present(longname)) then
584  fileObj%axes(axis_index)%longname = trim(longname)
585  else
586  fileObj%axes(axis_index)%longname = ""
587  endif
588 
589  return
590 end subroutine fms_io_unstructured_register_restart_axis_u
591 
592 !------------------------------------------------------------------------------
593 
594 !----------
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
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
i
l_size ! loop over number of fields ke do je do i
Definition: mpp_do_redistribute.h:71
write_ocean_data_mod::time
type(time_type) time
Definition: write_ocean_data.F90:49
crtm_parameters::no
integer, parameter, public no
Definition: CRTM_Parameters.f90:112
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
cloudcoeff_define::set
integer, parameter set
Definition: CloudCoeff_Define.f90:63
fms_io_mod::filename_appendix
character(len=32), save filename_appendix
Definition: fms_io.F90:523
field_manager_mod::fields
type(field_mgr_type), dimension(max_fields), private fields
Definition: field_manager.F90:536
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
stock_constants_mod::nelems
integer, parameter, public nelems
Definition: stock_constants.F90:33
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
fundamental_constants::e
real(fp), parameter, public e
Definition: Fundamental_Constants.f90:68
is
l_size ! loop over number of fields ke do je do ie to is
Definition: mpp_do_redistribute.h:72
c2f.type
type
Definition: c2f.py:15
length
************************************************************************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) MPP_BROADCAST length
Definition: mpp_transmit_mpi.h:179
T
************************************************************************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) & T
Definition: mpp_transmit_mpi.h:179
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
case
************************************************************************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 case
Definition: mpp_read_2Ddecomp.h:169
sim_nc_nlm_mod::calendar
subroutine calendar(year, month, day, hour)
Definition: sim_nc_nlm_mod.F90:405
interpolator_mod::sense
integer sense
No description.
Definition: interpolator.F90:330
fms_io_mod::get_mosaic_tile_file_ug
subroutine, public get_mosaic_tile_file_ug(file_in, file_out, domain)
Definition: fms_io.F90:7813
type_distribution::received
logical function received(this, seqno)
Definition: m_distribution.f90:72
interpolator_mod::len
integer len
Definition: interpolator.F90:321
field_manager_mod::root
type(field_def), target, save root
Definition: field_manager.F90:564
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)
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
min
#define min(a, b)
Definition: mosaic_util.h:32
c2f.module
module
Definition: c2f.py:21
tools_repro::eq
logical function, public eq(x, y)
Definition: tools_repro.F90:28