FV3 Bundle
mpp_get_boundary.h
Go to the documentation of this file.
1 ! -*-f90-*-
2 !***********************************************************************
3 !* GNU Lesser General Public License
4 !*
5 !* This file is part of the GFDL Flexible Modeling System (FMS).
6 !*
7 !* FMS is free software: you can redistribute it and/or modify it under
8 !* the terms of the GNU Lesser General Public License as published by
9 !* the Free Software Foundation, either version 3 of the License, or (at
10 !* your option) any later version.
11 !*
12 !* FMS is distributed in the hope that it will be useful, but WITHOUT
13 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 !* for more details.
16 !*
17 !* You should have received a copy of the GNU Lesser General Public
18 !* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
19 !***********************************************************************
20 ! this routine is used to retrieve scalar boundary data for symmetric domain.
21 
22 subroutine MPP_GET_BOUNDARY_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, &
23  position, complete, tile_count)
24  type(domain2D), intent(in) :: domain
25  MPP_TYPE_, intent(in) :: field(:,:)
26  MPP_TYPE_, intent(inout), optional :: ebuffer(:), sbuffer(:), wbuffer(:), nbuffer(:)
27  integer, intent(in), optional :: flags, position, tile_count
28  logical, intent(in), optional :: complete
29 
30  MPP_TYPE_ :: field3D(size(field,1),size(field,2),1)
31  MPP_TYPE_, allocatable, dimension(:,:) :: ebuffer2D, sbuffer2D, wbuffer2D, nbuffer2D
32  integer :: xcount, ycount
33 
34 
35  integer :: ntile
36  logical :: need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer
37  integer(LONG_KIND),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=-9999
38  integer(LONG_KIND),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=-9999
39  integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0, upflags
40  integer :: buffer_size(4)
41  integer :: max_ntile, tile, update_position, ishift, jshift
42  logical :: do_update, is_complete, set_mismatch
43  character(len=3) :: text
44  MPP_TYPE_ :: d_type
45  type(overlapSpec), pointer :: bound => NULL()
46 
47  ntile = size(domain%x(:))
48 
49  if(present(flags)) then
50  call mpp_error(FATAL, "MPP_GET_BOUNDARY_2D_: flags is a dummy optional argument")
51  endif
52  update_position = CENTER
53  if(present(position)) update_position = position
54 
55  !--- check if the buffer are needed
56  need_ebuffer=.false.; need_sbuffer=.false.; need_wbuffer=.false.; need_nbuffer=.false.
57  if( domain%symmetry .AND. PRESENT(position) ) then
58  select case(position)
59  case(CORNER)
60  need_ebuffer=.true.; need_sbuffer=.true.; need_wbuffer=.true.; need_nbuffer=.true.
61  case(NORTH)
62  need_sbuffer=.true.; need_nbuffer=.true.
63  case(EAST)
64  need_ebuffer=.true.; need_wbuffer=.true.
65  end select
66  end if
67 
68  tile = 1
69  max_ntile = domain%max_ntile_pe
70  is_complete = .true.
71  if(PRESENT(complete)) then
72  is_complete = complete
73  end if
74 
75  if(max_ntile>1) then
76  if(ntile>MAX_TILES) then
77  write( text,'(i2)' ) MAX_TILES
78  call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: MAX_TILES='//text//' is less than number of tiles on this pe.' )
79  endif
80  if(.NOT. present(tile_count) ) call mpp_error(FATAL, "MPP_GET_BOUNDARY_2D: "// &
81  "optional argument tile_count should be present when number of tiles on this pe is more than 1")
82  tile = tile_count
83  end if
84 
85  do_update = (tile == ntile) .AND. is_complete
86  list = list+1
87  if(list > MAX_DOMAIN_FIELDS)then
88  write( text,'(i2)' ) MAX_DOMAIN_FIELDS
89  call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' )
90  endif
91  f_addrs(list, tile) = LOC(field)
92  if(present(ebuffer)) then
93  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
94  'MPP_GET_BOUNDARY_2D: ebuffer should not be present when north is folded')
95  if(.not. need_ebuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: ebuffer should not be present')
96  b_addrs(1, list, tile) = LOC(ebuffer)
97  buffer_size(1) = size(ebuffer(:))
98  else
99  b_addrs(1, list, tile) = 0
100  buffer_size(1) = 1
101  end if
102  if(present(sbuffer)) then
103  if(.not. need_sbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: sbuffer should not be present')
104  b_addrs(2, list, tile) = LOC(sbuffer)
105  buffer_size(2) = size(sbuffer(:))
106  else
107  b_addrs(2, list, tile) = 0
108  buffer_size(2) = 1
109  end if
110  if(present(wbuffer)) then
111  if(.not. need_wbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: wbuffer should not be present')
112  b_addrs(3, list, tile) = LOC(wbuffer)
113  buffer_size(3) = size(wbuffer(:))
114  else
115  b_addrs(3, list, tile) = 0
116  buffer_size(3) = 1
117  end if
118  if(present(nbuffer)) then
119  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
120  'MPP_GET_BOUNDARY_2D: nbuffer should not be present when north is folded')
121  if(.not. need_nbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: nbuffer should be be present')
122  b_addrs(4, list, tile) = LOC(nbuffer)
123  buffer_size(4) = size(nbuffer(:))
124  else
125  b_addrs(4, list, tile) = 0
126  buffer_size(4) = 1
127  end if
128 
129  if(list == 1 .AND. tile == 1 )then
130  isize=size(field,1); jsize=size(field,2); ksize = 1; pos = update_position
131  bsize = buffer_size
132  else
133  set_mismatch = .false.
134  set_mismatch = set_mismatch .OR. (isize .NE. size(field,1))
135  set_mismatch = set_mismatch .OR. (jsize .NE. size(field,2))
136  set_mismatch = set_mismatch .OR. ANY( bsize .NE. buffer_size )
137  set_mismatch = set_mismatch .OR. (update_position .NE. pos)
138  if(set_mismatch)then
139  write( text,'(i2)' ) list
140  call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D: Incompatible field at count '//text//' for group update.' )
141  endif
142  endif
143  if(is_complete) then
144  l_size = list
145  list = 0
146  end if
147 
148  if(do_update )then
149  !--- only non-center data in symmetry domain will be retrieved.
150  if(position == CENTER .OR. (.NOT. domain%symmetry) ) return
151  bound => search_bound_overlap(domain, update_position)
152  call mpp_get_domain_shift(domain, ishift, jshift, update_position)
153  if(size(field,1) .NE. domain%x(1)%memory%size+ishift .OR. size(field,2) .NE. domain%y(1)%memory%size+jshift ) &
154  call mpp_error(FATAL, "MPP_GET_BOUNDARY_2D: field is not on memory domain")
155  if(ASSOCIATED(bound)) then
156  call mpp_do_get_boundary(f_addrs(1:l_size,1:ntile), domain, bound, b_addrs(:,1:l_size,1:ntile), &
157  bsize, ksize, d_type)
158  endif
159  l_size=0; f_addrs=-9999; bsize=0; b_addrs=-9999; isize=0; jsize=0; ksize=0
160  end if
161 
162  return
163 
164 end subroutine MPP_GET_BOUNDARY_2D_
165 
166 
167 !###############################################################################################
168 subroutine MPP_GET_BOUNDARY_3D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, &
169  position, complete, tile_count)
170  type(domain2D), intent(in) :: domain
171  MPP_TYPE_, intent(in) :: field(:,:,:)
172  MPP_TYPE_, intent(inout), optional :: ebuffer(:,:), sbuffer(:,:), wbuffer(:,:), nbuffer(:,:)
173  integer, intent(in), optional :: flags, position, tile_count
174  logical, intent(in), optional :: complete
175 
176  integer :: ntile
177  logical :: need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer
178  integer(LONG_KIND),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=-9999
179  integer(LONG_KIND),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=-9999
180  integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0, upflags
181  integer :: buffer_size(4)
182  integer :: max_ntile, tile, update_position, ishift, jshift
183  logical :: do_update, is_complete, set_mismatch
184  character(len=3) :: text
185  MPP_TYPE_ :: d_type
186  type(overlapSpec), pointer :: bound => NULL()
187 
188  ntile = size(domain%x(:))
189 
190  if(present(flags)) then
191  call mpp_error(FATAL, "MPP_GET_BOUNDARY_3D_: flags is a dummy optional argument")
192  endif
193  update_position = CENTER
194  if(present(position)) update_position = position
195 
196  !--- check if the suitable buffer are present
197  need_ebuffer=.false.; need_sbuffer=.false.; need_wbuffer=.false.; need_nbuffer=.false.
198  if( domain%symmetry .AND. PRESENT(position) ) then
199  select case(position)
200  case(CORNER)
201  need_ebuffer=.true.; need_sbuffer=.true.; need_wbuffer=.true.; need_nbuffer=.true.
202  case(NORTH)
203  need_sbuffer=.true.; need_nbuffer=.true.
204  case(EAST)
205  need_ebuffer=.true.; need_wbuffer=.true.
206  end select
207  end if
208 
209  tile = 1
210  max_ntile = domain%max_ntile_pe
211  is_complete = .true.
212  if(PRESENT(complete)) then
213  is_complete = complete
214  end if
215 
216  if(max_ntile>1) then
217  if(ntile>MAX_TILES) then
218  write( text,'(i2)' ) MAX_TILES
219  call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: MAX_TILES='//text//' is less than number of tiles on this pe.' )
220  endif
221  if(.NOT. present(tile_count) ) call mpp_error(FATAL, "MPP_GET_BOUNDARY_3D: "// &
222  "optional argument tile_count should be present when number of tiles on this pe is more than 1")
223  tile = tile_count
224  end if
225 
226  do_update = (tile == ntile) .AND. is_complete
227  list = list+1
228  if(list > MAX_DOMAIN_FIELDS)then
229  write( text,'(i2)' ) MAX_DOMAIN_FIELDS
230  call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' )
231  endif
232  f_addrs(list, tile) = LOC(field)
233  if(present(ebuffer)) then
234  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
235  'MPP_GET_BOUNDARY_3D: ebuffer should not be present when north is folded')
236  if(.not. need_ebuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: ebuffer should not be present')
237  b_addrs(1, list, tile) = LOC(ebuffer)
238  buffer_size(1) = size(ebuffer,1)
239  else
240  b_addrs(1, list, tile) = 0
241  buffer_size(1) = 1
242  end if
243  if(present(sbuffer)) then
244  if(.not. need_sbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: sbuffer should not be present')
245  b_addrs(2, list, tile) = LOC(sbuffer)
246  buffer_size(2) = size(sbuffer,1)
247  else
248  b_addrs(2, list, tile) = 0
249  buffer_size(2) = 1
250  end if
251  if(present(wbuffer)) then
252  if(.not. need_wbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: wbuffer should not be present')
253  b_addrs(3, list, tile) = LOC(wbuffer)
254  buffer_size(3) = size(wbuffer,1)
255  else
256  b_addrs(3, list, tile) = 0
257  buffer_size(3) = 1
258  end if
259  if(present(nbuffer)) then
260  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
261  'MPP_GET_BOUNDARY_3D: nbuffer should not be present when north is folded')
262  if(.not. need_nbuffer) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: nbuffer should not be present')
263  b_addrs(4, list, tile) = LOC(nbuffer)
264  buffer_size(4) = size(nbuffer,1)
265  else
266  b_addrs(4, list, tile) = 0
267  buffer_size(4) = 1
268  end if
269 
270 
271  if(list == 1 .AND. tile == 1 )then
272  isize=size(field,1); jsize=size(field,2); ksize = size(field,3); pos = update_position
273  bsize = buffer_size
274  else
275  set_mismatch = .false.
276  set_mismatch = set_mismatch .OR. (isize .NE. size(field,1))
277  set_mismatch = set_mismatch .OR. (jsize .NE. size(field,2))
278  set_mismatch = set_mismatch .OR. (ksize .NE. size(field,3))
279  set_mismatch = set_mismatch .OR. ANY( bsize .NE. buffer_size )
280  set_mismatch = set_mismatch .OR. (update_position .NE. pos)
281  if(set_mismatch)then
282  write( text,'(i2)' ) list
283  call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D: Incompatible field at count '//text//' for group update.' )
284  endif
285  endif
286  if(is_complete) then
287  l_size = list
288  list = 0
289  end if
290 
291  if(do_update )then
292  !--- only non-center data in symmetry domain will be retrieved.
293  if(position == CENTER .OR. (.NOT. domain%symmetry) ) return
294  bound => search_bound_overlap(domain, update_position)
295  call mpp_get_domain_shift(domain, ishift, jshift, update_position)
296  if(size(field,1) .NE. domain%x(1)%memory%size+ishift .OR. size(field,2) .NE. domain%y(1)%memory%size+jshift ) &
297  call mpp_error(FATAL, "MPP_GET_BOUNDARY_3D: field is not on memory domain")
298  if(ASSOCIATED(bound)) then
299  call mpp_do_get_boundary(f_addrs(1:l_size,1:ntile), domain, bound, b_addrs(:,1:l_size,1:ntile), &
300  bsize, ksize, d_type)
301  endif
302  l_size=0; f_addrs=-9999; bsize=0; b_addrs=-9999; isize=0; jsize=0; ksize=0
303  end if
304 
305 end subroutine MPP_GET_BOUNDARY_3D_
306 
307 
308 !####################################################################
309 ! vector update
310 subroutine MPP_GET_BOUNDARY_2D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wbufferx, nbufferx, &
311  ebuffery, sbuffery, wbuffery, nbuffery, flags, gridtype, &
312  complete, tile_count)
313  type(domain2D), intent(in) :: domain
314  MPP_TYPE_, intent(in) :: fieldx(:,:), fieldy(:,:)
315  MPP_TYPE_, intent(inout), optional :: ebufferx(:), sbufferx(:), wbufferx(:), nbufferx(:)
316  MPP_TYPE_, intent(inout), optional :: ebuffery(:), sbuffery(:), wbuffery(:), nbuffery(:)
317  integer, intent(in), optional :: flags, gridtype, tile_count
318  logical, intent(in), optional :: complete
319 
320  integer :: ntile, update_flags
321  logical :: need_ebufferx, need_sbufferx, need_wbufferx, need_nbufferx
322  logical :: need_ebuffery, need_sbuffery, need_wbuffery, need_nbuffery
323 
324  integer(LONG_KIND),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsx=-9999
325  integer(LONG_KIND),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsy=-9999
326  integer(LONG_KIND),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsx=-9999
327  integer(LONG_KIND),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsy=-9999
328  integer, save :: bsizex(4)=0, bsizey(4)=0, isize(2)=0, jsize(2)=0, ksize=0, l_size=0, list=0
329  integer, save :: offset_type, upflags
330  integer :: bufferx_size(4), buffery_size(4)
331  integer :: max_ntile, tile, grid_offset_type
332  logical :: do_update, is_complete, set_mismatch
333  character(len=3) :: text
334  MPP_TYPE_ :: d_type
335  type(overlapSpec), pointer :: boundx=>NULL()
336  type(overlapSpec), pointer :: boundy=>NULL()
337  integer :: position_x, position_y, ishift, jshift
338 
339  ntile = size(domain%x(:))
340  update_flags = 0
341  if( PRESENT(flags) ) then
342  update_flags = flags
343  end if
344 
345  !--- check if the suitable buffer are present
346  need_ebufferx=.FALSE.; need_sbufferx=.FALSE.
347  need_wbufferx=.FALSE.; need_nbufferx=.FALSE.
348  need_ebuffery=.FALSE.; need_sbuffery=.FALSE.
349  need_wbuffery=.FALSE.; need_nbuffery=.FALSE.
350  if( domain%symmetry .AND. PRESENT(gridtype) ) then
351  select case(gridtype)
352  case(BGRID_NE, BGRID_SW)
353  need_ebufferx=.true.; need_sbufferx=.true.; need_wbufferx=.true.; need_nbufferx=.true.
354  need_ebuffery=.true.; need_sbuffery=.true.; need_wbuffery=.true.; need_nbuffery=.true.
355  case(CGRID_NE, CGRID_SW)
356  need_ebufferx=.true.; need_wbufferx=.true.; need_sbuffery=.true.; need_nbuffery=.true.
357  case(DGRID_NE, DGRID_SW)
358  need_ebuffery=.true.; need_wbuffery=.true.; need_sbufferx=.true.; need_nbufferx=.true.
359  end select
360  end if
361 
362  tile = 1
363  max_ntile = domain%max_ntile_pe
364  is_complete = .true.
365  if(PRESENT(complete)) then
366  is_complete = complete
367  end if
368 
369  if(max_ntile>1) then
370  if(ntile>MAX_TILES) then
371  write( text,'(i2)' ) MAX_TILES
372  call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: MAX_TILES='//text//' is less than number of tiles on this pe.' )
373  endif
374  if(.NOT. present(tile_count) ) call mpp_error(FATAL, "MPP_GET_BOUNDARY_2D_V: "// &
375  "optional argument tile_count should be present when number of tiles on this pe is more than 1")
376  tile = tile_count
377  end if
378 
379  do_update = (tile == ntile) .AND. is_complete
380  list = list+1
381  if(list > MAX_DOMAIN_FIELDS)then
382  write( text,'(i2)' ) MAX_DOMAIN_FIELDS
383  call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' )
384  endif
385  f_addrsx(list, tile) = LOC(fieldx)
386  f_addrsy(list, tile) = LOC(fieldy)
387 
388  if(present(ebufferx)) then
389  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
390  'MPP_GET_BOUNDARY_2D_V: ebufferx should not be present when north is folded')
391  if(.not. need_ebufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: ebufferx should not be present')
392  b_addrsx(1, list, tile) = LOC(ebufferx)
393  bufferx_size(1) = size(ebufferx,1)
394  else
395  b_addrsx(1, list, tile) = 0
396  bufferx_size(1) = 1
397  end if
398  if(present(sbufferx)) then
399  if(.not. need_sbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: sbufferx should not be present')
400  b_addrsx(2, list, tile) = LOC(sbufferx)
401  bufferx_size(2) = size(sbufferx,1)
402  else
403  b_addrsx(2, list, tile) = 0
404  bufferx_size(2) = 1
405  end if
406  if(present(wbufferx)) then
407  if(.not. need_wbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: wbufferx should not be present')
408  b_addrsx(3, list, tile) = LOC(wbufferx)
409  bufferx_size(3) = size(wbufferx,1)
410  else
411  b_addrsx(3, list, tile) = 0
412  bufferx_size(3) = 1
413  end if
414  if(present(nbufferx)) then
415  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
416  'MPP_GET_BOUNDARY_2D_V: nbufferx should not be present when north is folded')
417  if(.not. need_nbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: nbufferx should not be present')
418  b_addrsx(4, list, tile) = LOC(nbufferx)
419  bufferx_size(4) = size(nbufferx,1)
420  else
421  b_addrsx(4, list, tile) = 0
422  bufferx_size(4) = 1
423  end if
424 
425  if(present(ebuffery)) then
426  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
427  'MPP_GET_BOUNDARY_2D_V: ebuffery should not be present when north is folded')
428  if(.not. need_ebuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: ebuffery should not be present')
429  b_addrsy(1, list, tile) = LOC(ebuffery)
430  buffery_size(1) = size(ebuffery,1)
431  else
432  b_addrsy(1, list, tile) = 0
433  buffery_size(1) = 1
434  end if
435  if(present(sbuffery)) then
436  if(.not. need_sbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: sbuffery should not be present')
437  b_addrsy(2, list, tile) = LOC(sbuffery)
438  buffery_size(2) = size(sbuffery,1)
439  else
440  b_addrsy(2, list, tile) = 0
441  buffery_size(2) = 1
442  end if
443  if(present(wbuffery)) then
444  if(.not. need_wbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: wbuffery should not be present')
445  b_addrsy(3, list, tile) = LOC(wbuffery)
446  buffery_size(3) = size(wbuffery,1)
447  else
448  b_addrsy(3, list, tile) = 0
449  buffery_size(3) = 1
450  end if
451  if(present(nbuffery)) then
452  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
453  'MPP_GET_BOUNDARY_2D_V: nbuffery should not be present when north is folded')
454  if(.not. need_nbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_2D_V: nbuffery should not be present')
455  b_addrsy(4, list, tile) = LOC(nbuffery)
456  buffery_size(4) = size(nbuffery,1)
457  else
458  b_addrsy(4, list, tile) = 0
459  buffery_size(4) = 1
460  end if
461 
462  grid_offset_type = AGRID
463  if(present(gridtype)) grid_offset_type = gridtype
464  if(list == 1 .AND. tile == 1 )then
465  isize(1)=size(fieldx,1); jsize(1)=size(fieldx,2); isize(2)=size(fieldy,1); jsize(2)=size(fieldy,2)
466  ksize = 1; offset_type = grid_offset_type
467  bsizex = bufferx_size; bsizey = buffery_size; upflags = update_flags
468  else
469  set_mismatch = .false.
470  set_mismatch = set_mismatch .OR. (isize(1) .NE. size(fieldx,1))
471  set_mismatch = set_mismatch .OR. (jsize(1) .NE. size(fieldx,2))
472  set_mismatch = set_mismatch .OR. (isize(2) .NE. size(fieldy,1))
473  set_mismatch = set_mismatch .OR. (jsize(2) .NE. size(fieldy,2))
474  set_mismatch = set_mismatch .OR. ANY( bsizex .NE. bufferx_size )
475  set_mismatch = set_mismatch .OR. ANY( bsizey .NE. buffery_size )
476  set_mismatch = set_mismatch .OR. (offset_type .NE. grid_offset_type)
477  set_mismatch = set_mismatch .OR. (upflags .NE. update_flags)
478  if(set_mismatch)then
479  write( text,'(i2)' ) list
480  call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: Incompatible field at count '//text//' for group update.' )
481  endif
482  endif
483  if(is_complete) then
484  l_size = list
485  list = 0
486  end if
487 
488  if(do_update )then
489  select case(grid_offset_type)
490  case (AGRID)
491  position_x = CENTER
492  position_y = CENTER
493  case (BGRID_NE, BGRID_SW)
494  position_x = CORNER
495  position_y = CORNER
496  case (CGRID_NE, CGRID_SW)
497  position_x = EAST
498  position_y = NORTH
499  case (DGRID_NE, DGRID_SW)
500  position_x = NORTH
501  position_y = EAST
502  case default
503  call mpp_error(FATAL, "mpp_get_boundary.h: invalid value of grid_offset_type")
504  end select
505 
506  boundx => search_bound_overlap(domain, position_x)
507  boundy => search_bound_overlap(domain, position_y)
508 
509  call mpp_get_domain_shift(domain, ishift, jshift, position_x)
510  if(size(fieldx,1) .NE. domain%x(1)%memory%size+ishift .OR. size(fieldx,2) .NE. domain%y(1)%memory%size+jshift ) &
511  call mpp_error(FATAL, "MPP_GET_BOUNDARY_2D_V: fieldx is not on memory domain")
512  call mpp_get_domain_shift(domain, ishift, jshift, position_y)
513  if(size(fieldy,1) .NE. domain%x(1)%memory%size+ishift .OR. size(fieldy,2) .NE. domain%y(1)%memory%size+jshift ) &
514  call mpp_error(FATAL, "MPP_GET_BOUNDARY_2D_V: fieldy is not on memory domain")
515  if(ASSOCIATED(boundx) ) then
516  call mpp_do_get_boundary(f_addrsx(1:l_size,1:ntile), f_addrsy(1:l_size,1:ntile), domain, boundx, boundy, &
517  b_addrsx(:,1:l_size,1:ntile), b_addrsy(:,1:l_size,1:ntile), bsizex, &
518  bsizey, ksize, d_type, update_flags, grid_offset_type)
519  endif
520  l_size=0; f_addrsx=-9999; f_addrsy=-9999; bsizex=0; bsizey=0;
521  b_addrsx=-9999; b_addrsy=-9999; isize=0; jsize=0; ksize=0
522  end if
523 
524 
525  return
526 
527 end subroutine MPP_GET_BOUNDARY_2D_V_
528 
529 
530 !###############################################################################################
531 subroutine MPP_GET_BOUNDARY_3D_V_(fieldx, fieldy, domain, ebufferx, sbufferx, wbufferx, nbufferx, &
532  ebuffery, sbuffery, wbuffery, nbuffery, flags, gridtype, &
533  complete, tile_count)
534  type(domain2D), intent(in) :: domain
535  MPP_TYPE_, intent(in) :: fieldx(domain%x(1)%memory%begin:,domain%y(1)%memory%begin:,:)
536  MPP_TYPE_, intent(in) :: fieldy(domain%x(1)%memory%begin:,domain%y(1)%memory%begin:,:)
537  MPP_TYPE_, intent(inout), optional :: ebufferx(:,:), sbufferx(:,:), wbufferx(:,:), nbufferx(:,:)
538  MPP_TYPE_, intent(inout), optional :: ebuffery(:,:), sbuffery(:,:), wbuffery(:,:), nbuffery(:,:)
539  integer, intent(in), optional :: flags, gridtype, tile_count
540  logical, intent(in), optional :: complete
541 
542  integer :: ntile, update_flags
543  logical :: need_ebufferx, need_sbufferx, need_wbufferx, need_nbufferx
544  logical :: need_ebuffery, need_sbuffery, need_wbuffery, need_nbuffery
545 
546  integer(LONG_KIND),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsx=-9999
547  integer(LONG_KIND),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrsy=-9999
548  integer(LONG_KIND),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsx=-9999
549  integer(LONG_KIND),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrsy=-9999
550  integer, save :: bsizex(4)=0, bsizey(4)=0, isize(2)=0, jsize(2)=0, ksize=0, l_size=0, list=0
551  integer, save :: offset_type, upflags
552  integer :: bufferx_size(4), buffery_size(4)
553  integer :: max_ntile, tile, grid_offset_type
554  logical :: do_update, is_complete, set_mismatch
555  character(len=3) :: text
556  MPP_TYPE_ :: d_type
557  type(overlapSpec), pointer :: boundx=>NULL()
558  type(overlapSpec), pointer :: boundy=>NULL()
559  integer :: position_x, position_y, ishift, jshift
560 
561  ntile = size(domain%x(:))
562  update_flags = 0
563  if( PRESENT(flags) ) then
564  update_flags = flags
565  end if
566 
567  !--- check if the suitable buffer are present
568  need_ebufferx=.FALSE.; need_sbufferx=.FALSE.
569  need_wbufferx=.FALSE.; need_nbufferx=.FALSE.
570  need_ebuffery=.FALSE.; need_sbuffery=.FALSE.
571  need_wbuffery=.FALSE.; need_nbuffery=.FALSE.
572  if( domain%symmetry .AND. PRESENT(gridtype) ) then
573  select case(gridtype)
574  case(BGRID_NE, BGRID_SW)
575  need_ebufferx=.true.; need_sbufferx=.true.; need_wbufferx=.true.; need_nbufferx=.true.
576  need_ebuffery=.true.; need_sbuffery=.true.; need_wbuffery=.true.; need_nbuffery=.true.
577  case(CGRID_NE, CGRID_SW)
578  need_ebufferx=.true.; need_wbufferx=.true.; need_sbuffery=.true.; need_nbuffery=.true.
579  case(DGRID_NE, DGRID_SW)
580  need_ebuffery=.true.; need_wbuffery=.true.; need_sbufferx=.true.; need_nbufferx=.true.
581  end select
582  end if
583 
584  tile = 1
585  max_ntile = domain%max_ntile_pe
586  is_complete = .true.
587  if(PRESENT(complete)) then
588  is_complete = complete
589  end if
590 
591  if(max_ntile>1) then
592  if(ntile>MAX_TILES) then
593  write( text,'(i2)' ) MAX_TILES
594  call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: MAX_TILES='//text//' is less than number of tiles on this pe.' )
595  endif
596  if(.NOT. present(tile_count) ) call mpp_error(FATAL, "MPP_GET_BOUNDARY_3D_V: "// &
597  "optional argument tile_count should be present when number of tiles on this pe is more than 1")
598  tile = tile_count
599  end if
600 
601  do_update = (tile == ntile) .AND. is_complete
602  list = list+1
603  if(list > MAX_DOMAIN_FIELDS)then
604  write( text,'(i2)' ) MAX_DOMAIN_FIELDS
605  call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' )
606  endif
607  f_addrsx(list, tile) = LOC(fieldx)
608  f_addrsy(list, tile) = LOC(fieldy)
609 
610  if(present(ebufferx)) then
611  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
612  'MPP_GET_BOUNDARY_3D_V: ebufferx should not be present when north is folded')
613  if(.not. need_ebufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: ebufferx should not be present')
614  b_addrsx(1, list, tile) = LOC(ebufferx)
615  bufferx_size(1) = size(ebufferx,1)
616  else
617  b_addrsx(1, list, tile) = 0
618  bufferx_size(1) = 1
619  end if
620  if(present(sbufferx)) then
621  if(.not. need_sbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: sbufferx should not be present')
622  b_addrsx(2, list, tile) = LOC(sbufferx)
623  bufferx_size(2) = size(sbufferx,1)
624  else
625  b_addrsx(2, list, tile) = 0
626  bufferx_size(2) = 1
627  end if
628  if(present(wbufferx)) then
629  if(.not. need_wbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: wbufferx should not be present')
630  b_addrsx(3, list, tile) = LOC(wbufferx)
631  bufferx_size(3) = size(wbufferx,1)
632  else
633  b_addrsx(3, list, tile) = 0
634  bufferx_size(3) = 1
635  end if
636  if(present(nbufferx)) then
637  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
638  'MPP_GET_BOUNDARY_3D_V: nbufferx should not be present when north is folded')
639  if(.not. need_nbufferx) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: nbufferx should not be present')
640  b_addrsx(4, list, tile) = LOC(nbufferx)
641  bufferx_size(4) = size(nbufferx,1)
642  else
643  b_addrsx(4, list, tile) = 0
644  bufferx_size(4) = 1
645  end if
646 
647  if(present(ebuffery)) then
648  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
649  'MPP_GET_BOUNDARY_3D_V: ebuffery should not be present when north is folded')
650  if(.not. need_ebuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: ebuffery should not be present')
651  b_addrsy(1, list, tile) = LOC(ebuffery)
652  buffery_size(1) = size(ebuffery,1)
653  else
654  b_addrsy(1, list, tile) = 0
655  buffery_size(1) = 1
656  end if
657  if(present(sbuffery)) then
658  if(.not. need_sbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: sbuffery should not be present')
659  b_addrsy(2, list, tile) = LOC(sbuffery)
660  buffery_size(2) = size(sbuffery,1)
661  else
662  b_addrsy(2, list, tile) = 0
663  buffery_size(2) = 1
664  end if
665  if(present(wbuffery)) then
666  if(.not. need_wbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: wbuffery should not be present')
667  b_addrsy(3, list, tile) = LOC(wbuffery)
668  buffery_size(3) = size(wbuffery,1)
669  else
670  b_addrsy(3, list, tile) = 0
671  buffery_size(3) = 1
672  end if
673  if(present(nbuffery)) then
674  if(BTEST(domain%fold,NORTH)) call mpp_error(FATAL, &
675  'MPP_GET_BOUNDARY_3D_V: nbuffery should not be present when north is folded')
676  if(.not. need_nbuffery) call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: nbuffery should not be present')
677  b_addrsy(4, list, tile) = LOC(nbuffery)
678  buffery_size(4) = size(nbuffery,1)
679  else
680  b_addrsy(4, list, tile) = 0
681  buffery_size(4) = 1
682  end if
683 
684  grid_offset_type = AGRID
685  if(present(gridtype)) grid_offset_type = gridtype
686  if(list == 1 .AND. tile == 1 )then
687  isize(1)=size(fieldx,1); jsize(1)=size(fieldx,2); isize(2)=size(fieldy,1); jsize(2)=size(fieldy,2)
688  ksize = size(fieldx,3); offset_type = grid_offset_type
689  bsizex = bufferx_size; bsizey = buffery_size; upflags = update_flags
690  else
691  set_mismatch = .false.
692  set_mismatch = set_mismatch .OR. (isize(1) .NE. size(fieldx,1))
693  set_mismatch = set_mismatch .OR. (jsize(1) .NE. size(fieldx,2))
694  set_mismatch = set_mismatch .OR. (ksize .NE. size(fieldx,3))
695  set_mismatch = set_mismatch .OR. (isize(2) .NE. size(fieldy,1))
696  set_mismatch = set_mismatch .OR. (jsize(2) .NE. size(fieldy,2))
697  set_mismatch = set_mismatch .OR. (ksize .NE. size(fieldy,3))
698  set_mismatch = set_mismatch .OR. ANY( bsizex .NE. bufferx_size )
699  set_mismatch = set_mismatch .OR. ANY( bsizey .NE. buffery_size )
700  set_mismatch = set_mismatch .OR. (offset_type .NE. grid_offset_type)
701  set_mismatch = set_mismatch .OR. (upflags .NE. update_flags)
702  if(set_mismatch)then
703  write( text,'(i2)' ) list
704  call mpp_error(FATAL,'MPP_GET_BOUNDARY_3D_V: Incompatible field at count '//text//' for group update.' )
705  endif
706  endif
707  if(is_complete) then
708  l_size = list
709  list = 0
710  end if
711 
712  if(do_update )then
713  select case(grid_offset_type)
714  case (AGRID)
715  position_x = CENTER
716  position_y = CENTER
717  case (BGRID_NE, BGRID_SW)
718  position_x = CORNER
719  position_y = CORNER
720  case (CGRID_NE, CGRID_SW)
721  position_x = EAST
722  position_y = NORTH
723  case (DGRID_NE, DGRID_SW)
724  position_x = NORTH
725  position_y = EAST
726  case default
727  call mpp_error(FATAL, "mpp_get_boundary.h: invalid value of grid_offset_type")
728  end select
729 
730  boundx => search_bound_overlap(domain, position_x)
731  boundy => search_bound_overlap(domain, position_y)
732 
733  call mpp_get_domain_shift(domain, ishift, jshift, position_x)
734  if(size(fieldx,1) .NE. domain%x(1)%memory%size+ishift .OR. size(fieldx,2) .NE. domain%y(1)%memory%size+jshift ) &
735  call mpp_error(FATAL, "MPP_GET_BOUNDARY_3D_V: fieldx is not on memory domain")
736  call mpp_get_domain_shift(domain, ishift, jshift, position_y)
737  if(size(fieldy,1) .NE. domain%x(1)%memory%size+ishift .OR. size(fieldy,2) .NE. domain%y(1)%memory%size+jshift ) &
738  call mpp_error(FATAL, "MPP_GET_BOUNDARY_3D_V: fieldy is not on memory domain")
739  if(ASSOCIATED(boundx) ) then
740  call mpp_do_get_boundary(f_addrsx(1:l_size,1:ntile), f_addrsy(1:l_size,1:ntile), domain, boundx, boundy, &
741  b_addrsx(:,1:l_size,1:ntile), b_addrsy(:,1:l_size,1:ntile), bsizex, &
742  bsizey, ksize, d_type, update_flags, grid_offset_type)
743  endif
744  l_size=0; f_addrsx=-9999; f_addrsy=-9999; bsizex=0; bsizey=0;
745  b_addrsx=-9999; b_addrsy=-9999; isize=0; jsize=0; ksize=0
746  end if
747 
748 end subroutine MPP_GET_BOUNDARY_3D_V_
749 
need_wbuffer
need_wbuffer
Definition: mpp_get_boundary.h:56
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
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
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
mpp_io_mod::text
character(len=256) text
Definition: mpp_io.F90:1051
NULL
*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:! ***********************************************************************! this routine is used to retrieve scalar boundary data for symmetric domain. subroutine MPP_GET_BOUNDARY_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, &position, complete, tile_count) type(domain2D), intent(in) ::domain MPP_TYPE_, intent(in) ::field(:,:) MPP_TYPE_, intent(inout), optional ::ebuffer(:), sbuffer(:), wbuffer(:), nbuffer(:) integer, intent(in), optional ::flags, position, tile_count logical, intent(in), optional ::complete MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_, allocatable, dimension(:,:) ::ebuffer2D, sbuffer2D, wbuffer2D, nbuffer2D integer ::xcount, ycount integer ::ntile logical ::need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer integer(LONG_KIND), dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save ::f_addrs=-9999 integer(LONG_KIND), dimension(4, MAX_DOMAIN_FIELDS, MAX_TILES), save ::b_addrs=-9999 integer, save ::bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0, upflags integer ::buffer_size(4) integer ::max_ntile, tile, update_position, ishift, jshift logical ::do_update, is_complete, set_mismatch character(len=3) ::text MPP_TYPE_ ::d_type type(overlapSpec), pointer ::bound=> NULL() ntile
Definition: mpp_get_boundary.h:45
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: mpp_get_boundary.h:5
binary_file_utility::false
integer(long), parameter false
Definition: Binary_File_Utility.f90:60
MPP_TYPE_
************************************************************************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 MPP_TYPE_
Definition: mpp_transmit_mpi.h:166
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
ensemble_manager_mod::pe
integer pe
Definition: ensemble_manager.F90:50
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
c2f.type
type
Definition: c2f.py:15
mpp_parameter_mod::center
integer, parameter, public center
Definition: mpp_parameter.F90:95
isize
************************************************************************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_GLOBAL_FIELD_2D_(domain, local, global, flags, position, tile_count, default_data) type(domain2D), intent(in) ::domain MPP_TYPE_, intent(in) ::local(:,:) MPP_TYPE_, intent(out) ::global(:,:) integer, intent(in), optional ::flags integer, intent(in), optional ::position integer, intent(in), optional ::tile_count MPP_TYPE_, intent(in), optional ::default_data MPP_TYPE_ ::local3D(size(local, 1), size(local, 2), 1) MPP_TYPE_ ::global3D(size(global, 1), size(global, 2), 1) pointer(lptr, local3D) pointer(gptr, global3D) lptr=LOC(local) gptr=LOC(global) call mpp_global_field(domain, local3D, global3D, flags, position, tile_count, default_data) end subroutine MPP_GLOBAL_FIELD_2D_ subroutine MPP_GLOBAL_FIELD_3D_(domain, local, global, flags, position, tile_count, default_data)!get a global field from a local field!local field may be on compute OR data domain type(domain2D), intent(in) ::domain MPP_TYPE_, intent(in) ::local(:,:,:) MPP_TYPE_, intent(out) ::global(:,:,:) integer, intent(in), optional ::flags integer, intent(in), optional ::position integer, intent(in), optional ::tile_count MPP_TYPE_, intent(in), optional ::default_data integer ::ishift, jshift integer ::tile integer ::isize, jsize tile=1;if(PRESENT(tile_count)) tile=tile_count call mpp_get_domain_shift(domain, ishift, jshift, position) ! The alltoallw method requires that local and global be contiguous. ! We presume that `local` is contiguous if it matches the data domain;! `global` is presumed to always be contiguous. ! Ideally we would use the F2015 function IS_CONTIGUOUS() to validate ! contiguity, but it is not yet suppored in many compilers. ! Also worth noting that many of the nD-> conversion also assumes so there many be other issues here isize
Definition: mpp_global_field.h:66
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
need_nbuffer
need_nbuffer
Definition: mpp_get_boundary.h:56
type_distribution::received
logical function received(this, seqno)
Definition: m_distribution.f90:72
fv3jedi_increment_mod::check
subroutine check(self)
Definition: fv3jedi_increment_mod.f90:1932
interpolator_mod::len
integer len
Definition: interpolator.F90:321
LONG_KIND
#define LONG_KIND
update_flags
*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_flags
Definition: mpp_update_nest_domains.h:79
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)
mpp_parameter_mod::north
integer, parameter, public north
Definition: mpp_parameter.F90:95
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)
type_diag::bound
real(kind_real), parameter bound
Definition: type_diag.F90:29
external_ic_nlm_mod::tile
integer, save tile
Definition: external_ic_nlm.F90:71
need_sbuffer
need_sbuffer
Definition: mpp_get_boundary.h:56
jsize
*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 jsize
Definition: mpp_update_nest_domains.h:79
pos
l_size ! loop over number of fields ke do je do ie pos
Definition: mpp_do_redistribute.h:72
begin
************************************************************************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 begin
Definition: mpp_transmit_mpi.h:179