FV3 Bundle
group_update_pack.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 if( group%k_loop_inside ) then
21 !$OMP parallel do default(none) shared(npack,group,ptr,nvector,ksize,buffer_start_pos) &
22 !$OMP private(buffer_pos,pos,m,is,ie,js,je,rotation, &
23 !$OMP ptr_field, ptr_fieldx, ptr_fieldy,n,k)
24  do n = 1, npack
25  buffer_pos = group%pack_buffer_pos(n) + buffer_start_pos
26  pos = buffer_pos
27  is = group%pack_is(n); ie = group%pack_ie(n)
28  js = group%pack_js(n); je = group%pack_je(n)
29  rotation = group%pack_rotation(n)
30  if( group%pack_type(n) == FIELD_S ) then
31  select case( rotation )
32  case(ZERO)
33  do l=1, group%nscalar ! loop over number of fields
34  ptr_field = group%addrs_s(l)
35  do k = 1, ksize
36  do j = js, je
37  do i = is, ie
38  pos = pos + 1
39  buffer(pos) = field(i,j,k)
40  end do
41  end do
42  enddo
43  enddo
44  case( MINUS_NINETY )
45  do l=1,group%nscalar ! loop over number of fields
46  ptr_field = group%addrs_s(l)
47  do k = 1, ksize
48  do i = is, ie
49  do j = je, js, -1
50  pos = pos + 1
51  buffer(pos) = field(i,j,k)
52  end do
53  end do
54  end do
55  end do
56  case( NINETY )
57  do l=1,group%nscalar ! loop over number of fields
58  ptr_field = group%addrs_s(l)
59  do k = 1, ksize
60  do i = ie, is, -1
61  do j = js, je
62  pos = pos + 1
63  buffer(pos) = field(i,j,k)
64  end do
65  end do
66  end do
67  end do
68  case( ONE_HUNDRED_EIGHTY )
69  do l=1,group%nscalar ! loop over number of fields
70  ptr_field = group%addrs_s(l)
71  do k = 1, ksize
72  do j = je, js, -1
73  do i = ie, is, -1
74  pos = pos + 1
75  buffer(pos) = field(i,j,k)
76  end do
77  end do
78  end do
79  end do
80  end select
81  else if( group%pack_type(n) == FIELD_X ) then
82  select case( rotation )
83  case(ZERO)
84  do l=1, nvector ! loop over number of fields
85  ptr_fieldx = group%addrs_x(l)
86  do k = 1, ksize
87  do j = js, je
88  do i = is, ie
89  pos = pos + 1
90  buffer(pos) = fieldx(i,j,k)
91  end do
92  end do
93  end do
94  end do
95  case( MINUS_NINETY )
96  if( BTEST(group%flags_v,SCALAR_BIT) ) then
97  do l=1,nvector ! loop over number of fields
98  ptr_fieldy = group%addrs_y(l)
99  do k = 1, ksize
100  do i = is, ie
101  do j = je, js, -1
102  pos = pos + 1
103  buffer(pos) = fieldy(i,j,k)
104  end do
105  end do
106  end do
107  end do
108  else
109  do l=1,nvector ! loop over number of fields
110  ptr_fieldy = group%addrs_y(l)
111  do k = 1, ksize
112  do i = is, ie
113  do j = je, js, -1
114  pos = pos + 1
115  buffer(pos) = -fieldy(i,j,k)
116  end do
117  end do
118  end do
119  end do
120  end if
121  case( NINETY )
122  do l=1, nvector ! loop over number of fields
123  ptr_fieldy = group%addrs_y(l)
124  do k = 1, ksize
125  do i = ie, is, -1
126  do j = js, je
127  pos = pos + 1
128  buffer(pos) = fieldy(i,j,k)
129  end do
130  end do
131  end do
132  end do
133  case( ONE_HUNDRED_EIGHTY )
134  if( BTEST(group%flags_v,SCALAR_BIT) ) then
135  do l=1,nvector ! loop over number of fields
136  ptr_fieldx = group%addrs_x(l)
137  do k = 1, ksize
138  do j = je, js, -1
139  do i = ie, is, -1
140  pos = pos + 1
141  buffer(pos) = fieldx(i,j,k)
142  end do
143  end do
144  end do
145  end do
146  else
147  do l=1,nvector ! loop over number of fields
148  ptr_fieldx = group%addrs_x(l)
149  do k = 1, ksize
150  do j = je, js, -1
151  do i = ie, is, -1
152  pos = pos + 1
153  buffer(pos) = -fieldx(i,j,k)
154  end do
155  end do
156  end do
157  end do
158  end if
159  end select ! select case( rotation(n) )
160  else if( group%pack_type(n) == FIELD_Y ) then
161  select case( rotation )
162  case(ZERO)
163  do l=1, nvector ! loop over number of fields
164  ptr_fieldy = group%addrs_y(l)
165  do k = 1, ksize
166  do j = js, je
167  do i = is, ie
168  pos = pos + 1
169  buffer(pos) = fieldy(i,j,k)
170  end do
171  end do
172  end do
173  end do
174  case( MINUS_NINETY )
175  do l=1,nvector ! loop over number of fields
176  ptr_fieldx = group%addrs_x(l)
177  do k = 1, ksize
178  do i = is, ie
179  do j = je, js, -1
180  pos = pos + 1
181  buffer(pos) = fieldx(i,j,k)
182  end do
183  end do
184  end do
185  end do
186  case( NINETY )
187  if( BTEST(group%flags_v,SCALAR_BIT) ) then
188  do l=1, nvector ! loop over number of fields
189  ptr_fieldx = group%addrs_x(l)
190  do k = 1, ksize
191  do i = ie, is, -1
192  do j = js, je
193  pos = pos + 1
194  buffer(pos) = fieldx(i,j,k)
195  end do
196  end do
197  end do
198  end do
199  else
200  do l=1,nvector ! loop over number of fields
201  ptr_fieldx = group%addrs_x(l)
202  do k = 1, ksize
203  do i = ie, is, -1
204  do j = js, je
205  pos = pos + 1
206  buffer(pos) = -fieldx(i,j,k)
207  end do
208  end do
209  end do
210  end do
211  end if
212  case( ONE_HUNDRED_EIGHTY )
213  if( BTEST(group%flags_v,SCALAR_BIT) ) then
214  do l=1,nvector ! loop over number of fields
215  ptr_fieldy = group%addrs_y(l)
216  do k = 1, ksize
217  do j = je, js, -1
218  do i = ie, is, -1
219  pos = pos + 1
220  buffer(pos) = fieldy(i,j,k)
221  end do
222  end do
223  end do
224  end do
225  else
226  do l=1,nvector ! loop over number of fields
227  ptr_fieldy = group%addrs_y(l)
228  do k = 1, ksize
229  do j = je, js, -1
230  do i = ie, is, -1
231  pos = pos + 1
232  buffer(pos) = -fieldy(i,j,k)
233  end do
234  end do
235  end do
236  end do
237  end if
238  end select ! select case( rotation(n) )
239  endif
240  enddo
241 else
242 !$OMP parallel do default(none) shared(npack,group,ptr,nvector,ksize,buffer_start_pos) &
243 !$OMP private(buffer_pos,pos,m,is,ie,js,je,rotation, &
244 !$OMP ptr_field, ptr_fieldx, ptr_fieldy,n,k)
245  do nk = 1, npack*ksize
246  n = (nk-1)/ksize + 1
247  k = mod((nk-1), ksize) + 1
248  buffer_pos = group%pack_buffer_pos(n) + buffer_start_pos
249  pos = buffer_pos + (k-1)*group%pack_size(n)
250  is = group%pack_is(n); ie = group%pack_ie(n)
251  js = group%pack_js(n); je = group%pack_je(n)
252  rotation = group%pack_rotation(n)
253  if( group%pack_type(n) == FIELD_S ) then
254  select case( rotation )
255  case(ZERO)
256  do l=1, group%nscalar ! loop over number of fields
257  ptr_field = group%addrs_s(l)
258  do j = js, je
259  do i = is, ie
260  pos = pos + 1
261  buffer(pos) = field(i,j,k)
262  end do
263  end do
264  enddo
265  case( MINUS_NINETY )
266  do l=1,group%nscalar ! loop over number of fields
267  ptr_field = group%addrs_s(l)
268  do i = is, ie
269  do j = je, js, -1
270  pos = pos + 1
271  buffer(pos) = field(i,j,k)
272  end do
273  end do
274  end do
275  case( NINETY )
276  do l=1,group%nscalar ! loop over number of fields
277  ptr_field = group%addrs_s(l)
278  do i = ie, is, -1
279  do j = js, je
280  pos = pos + 1
281  buffer(pos) = field(i,j,k)
282  end do
283  end do
284  end do
285  case( ONE_HUNDRED_EIGHTY )
286  do l=1,group%nscalar ! loop over number of fields
287  ptr_field = group%addrs_s(l)
288  do j = je, js, -1
289  do i = ie, is, -1
290  pos = pos + 1
291  buffer(pos) = field(i,j,k)
292  end do
293  end do
294  end do
295  end select
296  else if( group%pack_type(n) == FIELD_X ) then
297  select case( rotation )
298  case(ZERO)
299  do l=1, nvector ! loop over number of fields
300  ptr_fieldx = group%addrs_x(l)
301  do j = js, je
302  do i = is, ie
303  pos = pos + 1
304  buffer(pos) = fieldx(i,j,k)
305  end do
306  end do
307  end do
308  case( MINUS_NINETY )
309  if( BTEST(group%flags_v,SCALAR_BIT) ) then
310  do l=1,nvector ! loop over number of fields
311  ptr_fieldy = group%addrs_y(l)
312  do i = is, ie
313  do j = je, js, -1
314  pos = pos + 1
315  buffer(pos) = fieldy(i,j,k)
316  end do
317  end do
318  end do
319  else
320  do l=1,nvector ! loop over number of fields
321  ptr_fieldy = group%addrs_y(l)
322  do i = is, ie
323  do j = je, js, -1
324  pos = pos + 1
325  buffer(pos) = -fieldy(i,j,k)
326  end do
327  end do
328  end do
329  end if
330  case( NINETY )
331  do l=1, nvector ! loop over number of fields
332  ptr_fieldy = group%addrs_y(l)
333  do i = ie, is, -1
334  do j = js, je
335  pos = pos + 1
336  buffer(pos) = fieldy(i,j,k)
337  end do
338  end do
339  end do
340  case( ONE_HUNDRED_EIGHTY )
341  if( BTEST(group%flags_v,SCALAR_BIT) ) then
342  do l=1,nvector ! loop over number of fields
343  ptr_fieldx = group%addrs_x(l)
344  do j = je, js, -1
345  do i = ie, is, -1
346  pos = pos + 1
347  buffer(pos) = fieldx(i,j,k)
348  end do
349  end do
350  end do
351  else
352  do l=1,nvector ! loop over number of fields
353  ptr_fieldx = group%addrs_x(l)
354  do j = je, js, -1
355  do i = ie, is, -1
356  pos = pos + 1
357  buffer(pos) = -fieldx(i,j,k)
358  end do
359  end do
360  end do
361  end if
362  end select ! select case( rotation(n) )
363  else if( group%pack_type(n) == FIELD_Y ) then
364  select case( rotation )
365  case(ZERO)
366  do l=1, nvector ! loop over number of fields
367  ptr_fieldy = group%addrs_y(l)
368  do j = js, je
369  do i = is, ie
370  pos = pos + 1
371  buffer(pos) = fieldy(i,j,k)
372  end do
373  end do
374  end do
375  case( MINUS_NINETY )
376  do l=1,nvector ! loop over number of fields
377  ptr_fieldx = group%addrs_x(l)
378  do i = is, ie
379  do j = je, js, -1
380  pos = pos + 1
381  buffer(pos) = fieldx(i,j,k)
382  end do
383  end do
384  end do
385  case( NINETY )
386  if( BTEST(group%flags_v,SCALAR_BIT) ) then
387  do l=1, nvector ! loop over number of fields
388  ptr_fieldx = group%addrs_x(l)
389  do i = ie, is, -1
390  do j = js, je
391  pos = pos + 1
392  buffer(pos) = fieldx(i,j,k)
393  end do
394  end do
395  end do
396  else
397  do l=1,nvector ! loop over number of fields
398  ptr_fieldx = group%addrs_x(l)
399  do i = ie, is, -1
400  do j = js, je
401  pos = pos + 1
402  buffer(pos) = -fieldx(i,j,k)
403  end do
404  end do
405  end do
406  end if
407  case( ONE_HUNDRED_EIGHTY )
408  if( BTEST(group%flags_v,SCALAR_BIT) ) then
409  do l=1,nvector ! loop over number of fields
410  ptr_fieldy = group%addrs_y(l)
411  do j = je, js, -1
412  do i = ie, is, -1
413  pos = pos + 1
414  buffer(pos) = fieldy(i,j,k)
415  end do
416  end do
417  end do
418  else
419  do l=1,nvector ! loop over number of fields
420  ptr_fieldy = group%addrs_y(l)
421  do j = je, js, -1
422  do i = ie, is, -1
423  pos = pos + 1
424  buffer(pos) = -fieldy(i,j,k)
425  end do
426  end do
427  end do
428  end if
429  end select ! select case( rotation(n) )
430  endif
431  enddo
432 endif
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
i
l_size ! loop over number of fields ke do je do i
Definition: mpp_do_redistribute.h:71
fms_io_mod::je
integer, private je
Definition: fms_io.F90:494
crtm_lowfrequency_mwssem::n
integer n
Definition: CRTM_LowFrequency_MWSSEM.f90:172
ksize
*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 ksize
Definition: mpp_update_nest_domains.h:79
oda_core_mod::nk
integer, save, private nk
Definition: oda_core.F90:126
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
field_manager_mod::fields
type(field_mgr_type), dimension(max_fields), private fields
Definition: field_manager.F90:536
time_interp_mod::none
integer, parameter, public none
Definition: time_interp.F90:204
j
l_size ! loop over number of fields ke do j
Definition: mpp_do_redistribute.h:70
mersennetwister_mod::m
integer, parameter m
Definition: MersenneTwister.F90:79
diag_integral_mod::version
character(len=128) version
Definition: diag_integral.F90:121
is
l_size ! loop over number of fields ke do je do ie to is
Definition: mpp_do_redistribute.h:72
fms_io_mod::ie
integer, private ie
Definition: fms_io.F90:494
gsw_mod_sp_coefficients::k
real(r8), parameter k
Definition: gsw_mod_sp_coefficients.f90:40
diag_data_mod::pack_size
integer pack_size
Definition: diag_data.F90:749
type_distribution::received
logical function received(this, seqno)
Definition: m_distribution.f90:72
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
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
pos
l_size ! loop over number of fields ke do je do ie pos
Definition: mpp_do_redistribute.h:72
js
l_size ! loop over number of fields ke do je do ie to js
Definition: mpp_do_redistribute.h:72