FV3 Bundle
fms_io_unstructured_setup_one_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 !>Add a field to a restart object (restart_file_type). Return the index of the
23 !!inputted field in the fileObj%var array.
24 subroutine fms_io_unstructured_setup_one_field(fileObj, &
25  filename, &
26  fieldname, &
27  field_dimension_order, &
28  field_dimension_sizes, &
29  index_field, &
30  domain, &
31  mandatory, &
32  data_default, &
33  longname, &
34  units, &
35  read_only, &
36  owns_data)
37 
38  !Inputs/Outputs
39  type(restart_file_type),intent(inout) :: fileObj !<A restart object.
40  character(len=*),intent(in) :: filename !<The name of the restart file.
41  character(len=*),intent(in) :: fieldname !<The name of a field.
42  integer(INT_KIND),dimension(:),intent(in) :: field_dimension_order !<Array telling the ordering of the dimensions for the field.
43  integer(INT_KIND),dimension(NIDX),intent(in) :: field_dimension_sizes !<Array of sizes of the dimensions of the inputted field.
44  integer(INT_KIND),intent(out) :: index_field !<Index of the inputted field in the fileObj%var array.
45  type(domainUG),intent(in),target :: domain !<An unstructured mpp domain.
46  logical(INT_KIND),intent(in),optional :: mandatory !<Flag telling if the field is mandatory for the restart.
47  real,intent(in),optional :: data_default !<A default value for the data.
48  character(len=*),intent(in),optional :: longname !<A more descriptive name of the field.
49  character(len=*),intent(in),optional :: units !<Units for the field.
50  logical(INT_KIND),intent(in),optional :: read_only !<Tells whether or not the variable will be written to the restart file.
51  logical(INT_KIND),intent(in),optional :: owns_data !<Tells if the data will be deallocated when the restart object is deallocated.
52 
53  !Local variables
54  real(DOUBLE_KIND) :: default_data !<The "default" data value. This defaults to MPP_FILL_DOUBLE. Shouldn't this be a real(DOUBLE_KIND)?
55  character(len=256) :: filename2 !<A string used to manipulate the inputted filename.
56  integer(INT_KIND) :: length !<the length of the (trimmed) inputted file name.
57  character(len=256) :: append_string !<A string used to append the filename_appendix module variable string to the inputted filename.
58  character(len=256) :: fname !<A string to hold a file name.
59  type(var_type),pointer :: cur_var !<A convenience pointer.
60  integer(INT_KIND) :: i !<Loop variable.
61  character(len=256) :: error_msg !<An error message string.
62 
63  !Make sure that the field does not have more than five dimensions.
64  if (size(field_dimension_order) .gt. 5) then
65  call mpp_error(FATAL, &
66  "fms_io_unstructured_setup_one_field:" &
67  //" the inputted field cannot contain more than" &
68  //" five dimensions.")
69  endif
70 
71  !Make sure that each dimension size is greater than zero.
72  if (any(field_dimension_sizes .lt. 0)) then
73  call mpp_error(FATAL, &
74  "fms_io_unstructured_setup_one_field:" &
75  //" all dimensions must have a size that is a non-" &
76  //" negative integer.")
77  endif
78 
79  !Set the "default" data value for the field.
80  if (present(data_default)) then
81  default_data = data_default
82  else
83  default_data = MPP_FILL_DOUBLE
84  endif
85 
86  !Remove the ".nc" from file name.
87  length = len_trim(filename)
88  if (filename(length-2:length) .eq. ".nc") then
89  filename2 = filename(1:length-3)
90  else
91  filename2 = filename(1:length)
92  endif
93 
94  !Append the filename_appendix string to the file name.
95  !filename_appendix is a module variable.
96  append_string = ""
97  if (len_trim(filename_appendix) .gt. 0) then
98  append_string = filename_appendix
99  endif
100  if (len_trim(append_string) .gt. 0) then
101  filename2 = trim(filename2)//'.'//trim(append_string)
102  endif
103 
104  !If necessary, add the correct domain ".tilexxxx" string to the inputted
105  !file name. For a file named foo.nc, this would become foo.tilexxxx.nc.
106  call get_mosaic_tile_file_ug(filename2, &
107  fname, &
108  domain)
109 
110  if (associated(fileObj%var)) then
111 
112  !Make sure that the filename stored in fileObj matches the filename
113  !returned from get_mosaic_tile_file_ug.
114  if (trim(fileObj%name) .ne. trim(fname)) then
115  call mpp_error(FATAL, &
116  "fms_io_unstructured_setup_one_field:" &
117  //" filename = "//trim(fname)//" is not" &
118  //" consistent with the filename of the" &
119  //" restart object = "//trim(fileObj%name))
120  endif
121  else
122 
123  !If any axis has already been registered, then make sure that the
124  !filename returned from get_mosaic_tile_file_ug matches the filename
125  !stored in the fileObj restart object. If this is the first axis/
126  !field registered to the restart object, then store the filename
127  !returned from get_mosaic_tile_file_ug in the restart object.
128  if (allocated(fileObj%axes)) then
129  if (trim(fileObj%name) .ne. trim(fname)) then
130  call mpp_error(FATAL, &
131  "fms_io_unstructured_setup_one_field:" &
132  //" filename = "//trim(fname)//" is not" &
133  //" consistent with the filename of the" &
134  //" restart object = "//trim(fileObj%name))
135  endif
136  else
137  fileObj%name = trim(fname)
138  endif
139 
140  !Allocate necessary space in hte restart object.
141  allocate(fileObj%var(max_fields))
142  allocate(fileObj%p0dr(MAX_TIME_LEVEL_REGISTER,max_fields))
143  allocate(fileObj%p1dr(MAX_TIME_LEVEL_REGISTER,max_fields))
144  allocate(fileObj%p2dr(MAX_TIME_LEVEL_REGISTER,max_fields))
145  allocate(fileObj%p3dr(MAX_TIME_LEVEL_REGISTER,max_fields))
146  allocate(fileObj%p4dr(MAX_TIME_LEVEL_REGISTER,max_fields))
147  allocate(fileObj%p2dr8(MAX_TIME_LEVEL_REGISTER,max_fields))
148  allocate(fileObj%p3dr8(MAX_TIME_LEVEL_REGISTER,max_fields))
149  allocate(fileObj%p0di(MAX_TIME_LEVEL_REGISTER,max_fields))
150  allocate(fileObj%p1di(MAX_TIME_LEVEL_REGISTER,max_fields))
151  allocate(fileObj%p2di(MAX_TIME_LEVEL_REGISTER,max_fields))
152  allocate(fileObj%p3di(MAX_TIME_LEVEL_REGISTER,max_fields))
153 
154  !Make sure that the restart file name is not currently being used by
155  !an other restart objects. Shouldn't this be fatal?
156  !num_registered files is a module variable.
157  do i = 1,num_registered_files
158  if (trim(fname) .eq. trim(registered_file(i))) then
159  call mpp_error(FATAL, &
160  "fms_io_unstructured_setup_one_field: " &
161  //trim(fname)//" is already registered with" &
162  //" another restart_file_type data.")
163  exit
164  endif
165  enddo
166 
167  !Iterate the number of registered restart files, and add the inputted
168  !file to the array. Should this be fatal?
169  !max_files_w is a module variable.
172  call mpp_error(FATAL, &
173  "fms_io_unstructured_setup_one_field:" &
174  //" the number of registered files is greater" &
175  //" than max_files_w. Please increase" &
176  //" max_files_w in the fms_io_nml namelist.")
177  endif
179 
180  !Set values for the restart object.
181  !max_fields is a module variable.
182  fileObj%register_id = num_registered_files
183  fileObj%max_ntime = field_dimension_sizes(TIDX)
184  fileObj%is_root_pe = mpp_domain_UG_is_tile_root_pe(domain)
185  fileObj%nvar = 0
186  do i = 1,max_fields
187  fileObj%var(i)%name = "none"
188  fileObj%var(i)%longname = "";
189  fileObj%var(i)%units = "none";
190  fileObj%var(i)%domain_present = .false.
191  fileObj%var(i)%domain_idx = -1
192  fileObj%var(i)%is_dimvar = .false.
193  fileObj%var(i)%read_only = .false.
194  fileObj%var(i)%owns_data = .false.
195  fileObj%var(i)%position = CENTER
196  fileObj%var(i)%ndim = -1
197  fileObj%var(i)%siz(:) = -1
198  fileObj%var(i)%gsiz(:) = -1
199  fileObj%var(i)%id_axes(:) = -1
200  fileObj%var(i)%initialized = .false.
201  fileObj%var(i)%mandatory = .true.
202  fileObj%var(i)%is = -1
203  fileObj%var(i)%ie = -1
204  fileObj%var(i)%js = -1
205  fileObj%var(i)%je = -1
206  fileObj%var(i)%default_data = -1
207  fileObj%var(i)%compressed_axis = ""
208  fileObj%var(i)%ishift = -1
209  fileObj%var(i)%jshift = -1
210  fileObj%var(i)%x_halo = -1
211  fileObj%var(i)%y_halo = -1
212  fileObj%var(i)%field_dimension_order(:) = -1
213  fileObj%var(i)%field_dimension_sizes(:) = -1
214  enddo
215  endif
216 
217  !Get the index of the field in the fileObj%var array, if it exists. If
218  !it doesn't exist, set the index to be -1.
219  index_field = -1
220  do i = 1,fileObj%nvar
221  if (trim(fileObj%var(i)%name) .eq. trim(fieldname)) then
222  index_field = i
223  exit
224  endif
225  enddo
226 
227  if (index_field > 0) then
228 
229  !If the field already exists in the fileObj%var array, then update its
230  !time level.
231  cur_var => null()
232  cur_var => fileObj%var(index_field)
233 
234  !Make sure tha the inputted array describing the ordering of the
235  !dimensions for the field matches the dimension ordering for the
236  !found field.
237  do i = 1,size(field_dimension_order)
238  if (field_dimension_order(i) .ne. cur_var%field_dimension_order(i)) then
239  call mpp_error(FATAL, &
240  "fms_io_unstructured_setup_one_field:" &
241  //" field dimension ordering mismatch for " &
242  //trim(fieldname)//" of file "//trim(filename))
243  endif
244  enddo
245 
246  !Make sure that the array of field dimension sizes matches the
247  !dimension sizes of the found field for all dimensions except the
248  !time level.
249  if (cur_var%field_dimension_sizes(XIDX) .ne. field_dimension_sizes(XIDX) .or. &
250  cur_var%field_dimension_sizes(YIDX) .ne. field_dimension_sizes(YIDX) .or. &
251  cur_var%field_dimension_sizes(CIDX) .ne. field_dimension_sizes(CIDX) .or. &
252  cur_var%field_dimension_sizes(ZIDX) .ne. field_dimension_sizes(ZIDX) .or. &
253  cur_var%field_dimension_sizes(HIDX) .ne. field_dimension_sizes(HIDX) .or. &
254  cur_var%field_dimension_sizes(UIDX) .ne. field_dimension_sizes(UIDX) .or. &
255  cur_var%field_dimension_sizes(CCIDX) .ne. field_dimension_sizes(CCIDX)) then
256  call mpp_error(FATAL, &
257  "fms_io_unstructured_setup_one_field:" &
258  //" field dimension size mismatch for field " &
259  //trim(fieldname)//" of file "//trim(filename))
260  endif
261 
262  !Update the time level.
263  cur_var%siz(4) = cur_var%siz(4) + field_dimension_sizes(TIDX)
264  if (fileObj%max_ntime .lt. cur_var%siz(4)) then
265  fileObj%max_ntime = cur_var%siz(4)
266  endif
267  if (cur_var%siz(4) .gt. MAX_TIME_LEVEL_REGISTER) then
268  call mpp_error(FATAL, &
269  "fms_io_unstructured_setup_one_field:" &
270  //" the time level of field "//trim(cur_var%name) &
271  //" in file "//trim(fileObj%name)//" is greater" &
272  //" than MAX_TIME_LEVEL_REGISTER(=2), increase" &
273  //" MAX_TIME_LEVEL_REGISTER or check your code.")
274  endif
275  else
276 
277  !If this is a new field, then add it the restart object.
278  fileObj%nvar = fileObj%nvar + 1
279  if (fileObj%nvar .gt. max_fields) then
280  write(error_msg,'(I3,"/",I3)') fileObj%nvar,max_fields
281  call mpp_error(FATAL, &
282  "fms_io_unstructured_setup_one_field:" &
283  //" max_fields exceeded, needs increasing," &
284  //" nvar/max_fields = "//trim(error_msg))
285  endif
286  index_field = fileObj%nvar
287  cur_var => null()
288  cur_var => fileObj%var(index_field)
289 
290  !Point to the inputted unstructured domain.
291  cur_var%domain_ug => domain
292 
293  !Copy in the dimension sizes of the data domain (siz, used for
294  !writes), and of the global domain (gsiz, used for reads).
295  cur_var%field_dimension_sizes = field_dimension_sizes
296  do i = 1,size(field_dimension_order)
297  cur_var%field_dimension_order(i) = field_dimension_order(i)
298  enddo
299  cur_var%siz(4) = field_dimension_sizes(TIDX)
300 
301  !Copy in the rest of the data.
302  cur_var%name = fieldname
303  cur_var%default_data = real(default_data)
304  if (present(mandatory)) then
305  cur_var%mandatory = mandatory
306  endif
307  if (present(read_only)) then
308  cur_var%read_only = read_only
309  endif
310  if (present(owns_data)) then
311  cur_var%owns_data = owns_data
312  endif
313  if (present(longname)) then
314  cur_var%longname = longname
315  else
316  cur_var%longname = fieldname
317  endif
318  if (present(units)) then
319  cur_var%units = units
320  endif
321  endif
322 
323  !Nullify local pointer.
324  cur_var => null()
325 
326  return
327 end subroutine fms_io_unstructured_setup_one_field
328 
329 !----------
************************************************************************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
type(ext_fieldtype), dimension(:), pointer, save, private field
*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
l_size ! loop over number of fields ke do je do i
integer max_files_w
Definition: fms_io.F90:538
character(len=128), dimension(:), allocatable registered_file
Definition: fms_io.F90:497
integer, private je
Definition: fms_io.F90:494
subroutine, public add(value, cumul, num, wgt)
Definition: tools_func.F90:185
subroutine, public copy(self, rhs)
character(len=32) units
No description.
character(len=32) name
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
character(len=128) version
l_size ! loop over number of fields ke do je do ie to is
type
Definition: c2f.py:15
type(file_type), dimension(:), allocatable, save files
Definition: diag_data.F90:780
integer nvar
No description.
integer, private ie
Definition: fms_io.F90:494
************************************************************************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
integer num_registered_files
Definition: fms_io.F90:482
logical function received(this, seqno)
************************************************************************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
*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)
integer, parameter, public fatal
real(r8), dimension(cast_m, cast_n) t
*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
#define INT_KIND
#define DOUBLE_KIND
integer, parameter max_fields
Definition: xgrid.F90:183
l_size ! loop over number of fields ke do je do ie to js
module
Definition: c2f.py:21
logical function, public eq(x, y)
Definition: tools_repro.F90:28
integer ndim
No description.