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