1 !***********************************************************************
2 !* GNU Lesser General Public License
4 !* This file
is part of the GFDL Flexible Modeling System (FMS).
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.
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
16 !* You should have
received a copy of the GNU Lesser General Public
17 !* License along with FMS. If
not, see <http:
18 !***********************************************************************
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, &
27 field_dimension_order, &
28 field_dimension_sizes, &
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.
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.
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. 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.") 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.") 79 !Set the "default" data value for the field. 80 if (present(data_default)) then 81 default_data = data_default 83 default_data = MPP_FILL_DOUBLE 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) 91 filename2 = filename(1:length) 94 !Append the filename_appendix string to the file name. 95 !filename_appendix is a module variable. 97 if (len_trim(filename_appendix) .gt. 0) then 98 append_string = filename_appendix 100 if (len_trim(append_string) .gt. 0) then 101 filename2 = trim(filename2)//'.
'//trim(append_string) 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, & 110 if (associated(fileObj%var)) then 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)) 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)) 137 fileObj%name = trim(fname) 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)) 154 !Make sure that the restart file name is not currently being used by 155 !an other restart objects. Shouldn't this be
fatal?
160 "fms_io_unstructured_setup_one_field: " &
167 !Iterate the number of registered restart
files, and
add the inputted
168 !file to the array. Should this be
fatal?
173 "fms_io_unstructured_setup_one_field:" &
180 !Set values for the restart object.
183 fileObj%max_ntime = field_dimension_sizes(TIDX)
184 fileObj%is_root_pe = mpp_domain_UG_is_tile_root_pe(domain)
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
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. 220 do i = 1,fileObj%nvar 221 if (trim(fileObj%var(i)%name) .eq. trim(fieldname)) then 227 if (index_field > 0) then 229 !If the field already exists in the fileObj%var array, then update its 232 cur_var => fileObj%var(index_field) 234 !Make sure tha the inputted array describing the ordering of the 235 !dimensions for the field matches the dimension ordering for the 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)) 246 !Make sure that the array of field dimension sizes matches the 247 !dimension sizes of the found field for all dimensions except the 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)) 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) 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.") 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)) 286 index_field = fileObj%nvar 288 cur_var => fileObj%var(index_field) 290 !Point to the inputted unstructured domain. 291 cur_var%domain_ug => domain 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) 299 cur_var%siz(4) = field_dimension_sizes(TIDX) 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 307 if (present(read_only)) then 308 cur_var%read_only = read_only 310 if (present(owns_data)) then 311 cur_var%owns_data = owns_data 313 if (present(longname)) then 314 cur_var%longname = longname 316 cur_var%longname = fieldname 318 if (present(units)) then 319 cur_var%units = units 323 !Nullify local pointer. 327 end subroutine fms_io_unstructured_setup_one_field ************************************************************************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
character(len=128), dimension(:), allocatable registered_file
subroutine, public copy(self, rhs)
character(len=32) units
No description.
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(file_type), dimension(:), allocatable, save files
integer nvar
No description.
************************************************************************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
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
integer, parameter max_fields
l_size ! loop over number of fields ke do je do ie to js
integer ndim
No description.