FV3 Bundle
mpp_update_domains2D_nonblock.h
Go to the documentation of this file.
1 !***********************************************************************
2 !* GNU Lesser General Public License
3 !*
4 !* This file is part of the GFDL Flexible Modeling System (FMS).
5 !*
6 !* FMS is free software: you can redistribute it and/or modify it under
7 !* the terms of the GNU Lesser General Public License as published by
8 !* the Free Software Foundation, either version 3 of the License, or (at
9 !* your option) any later version.
10 !*
11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
14 !* for more details.
15 !*
16 !* You should have received a copy of the GNU Lesser General Public
17 !* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
18 !***********************************************************************
19 function MPP_START_UPDATE_DOMAINS_2D_( field, domain, flags, position, &
20  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete)
21  type(domain2D), intent(inout) :: domain
22  MPP_TYPE_, intent(inout) :: field(:,:)
23  integer, intent(in), optional :: flags
24  integer, intent(in), optional :: position
25  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated.
26  character(len=*), intent(in), optional :: name
27  integer, intent(in), optional :: tile_count
28  integer, intent(in), optional :: update_id
29  logical, intent(in), optional :: complete
30  integer :: MPP_START_UPDATE_DOMAINS_2D_
31 
32  MPP_TYPE_ :: field3D(size(field,1),size(field,2),1)
33  pointer( ptr, field3D )
34  ptr = LOC(field)
35 
36  MPP_START_UPDATE_DOMAINS_2D_ = mpp_start_update_domains(field3D, domain, flags, position, &
37  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete)
38  return
39 
40 end function MPP_START_UPDATE_DOMAINS_2D_
41 
42 function MPP_START_UPDATE_DOMAINS_3D_( field, domain, flags, position, &
43  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete )
44 
45  type(domain2D), intent(inout) :: domain
46  MPP_TYPE_, intent(inout) :: field(domain%x(1)%data%begin:,domain%y(1)%data%begin:,:)
47  integer, intent(in), optional :: flags
48  integer, intent(in), optional :: position
49  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated.
50  character(len=*), intent(in), optional :: name
51  integer, intent(in), optional :: tile_count
52  integer, intent(in), optional :: update_id
53  logical, intent(in), optional :: complete
54  integer :: MPP_START_UPDATE_DOMAINS_3D_
55 
56  !--- local variables
57  integer :: current_id, ke_max
58  integer :: update_whalo, update_ehalo, update_shalo, update_nhalo, update_flags, update_position
59  integer :: tile, max_ntile, ntile, n, l
60  logical :: set_mismatch, is_complete
61  logical :: do_update, reuse_id_update
62  integer, save :: isize=0, jsize=0, l_size=0, list=0
63  integer, save :: pos, whalosz, ehalosz, shalosz, nhalosz, update_flags_saved
64  character(len=128) :: text, field_name
65  integer, save :: ke_list(MAX_DOMAIN_FIELDS, MAX_TILES)=0
66  integer(LONG_KIND), save :: f_addrs(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999
67  type(overlapSpec), pointer :: update => NULL()
68  MPP_TYPE_ :: d_type
69 
70  field_name = "unknown"
71  if(present(name)) field_name = name
72 
73  if(present(whalo)) then
74  update_whalo = whalo
75  if(abs(update_whalo) > domain%whalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D: "// &
76  "optional argument whalo should not be larger than the whalo when define domain.")
77  else
78  update_whalo = domain%whalo
79  end if
80  if(present(ehalo)) then
81  update_ehalo = ehalo
82  if(abs(update_ehalo) > domain%ehalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D: "// &
83  "optional argument ehalo should not be larger than the ehalo when define domain.")
84  else
85  update_ehalo = domain%ehalo
86  end if
87  if(present(shalo)) then
88  update_shalo = shalo
89  if(abs(update_shalo) > domain%shalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D: "// &
90  "optional argument shalo should not be larger than the shalo when define domain.")
91  else
92  update_shalo = domain%shalo
93  end if
94  if(present(nhalo)) then
95  update_nhalo = nhalo
96  if(abs(update_nhalo) > domain%nhalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D: "// &
97  "optional argument nhalo should not be larger than the nhalo when define domain.")
98  else
99  update_nhalo = domain%nhalo
100  end if
101 
102  update_flags = XUPDATE+YUPDATE !default
103  if( PRESENT(flags) )update_flags = flags
104 
105  update_position = CENTER
106  if(present(position)) then
107  !--- when there is NINETY or MINUS_NINETY rotation for some contact, the salar data can not be on E or N-cell,
108  if(domain%rotated_ninety .AND. ( position == EAST .OR. position == NORTH ) ) &
109  call mpp_error(FATAL, 'MPP_START_UPDATE_DOMAINS_3D: hen there is NINETY or MINUS_NINETY rotation, ' // &
110  'can not use scalar version update_domain for data on E or N-cell' )
111  update_position = position
112  endif
113 
114  max_ntile = domain%max_ntile_pe
115  ntile = size(domain%x(:))
116  is_complete = .true.
117  if(PRESENT(complete)) then
118  is_complete = complete
119  end if
120  tile = 1
121 
122  if(max_ntile>1) then
123  if(ntile>MAX_TILES) then
124  write( text,'(i2)' ) MAX_TILES
125  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_3D: MAX_TILES='//text//' is less than number of tiles on this pe.' )
126  endif
127  if(.NOT. present(tile_count) ) call mpp_error(FATAL, "MPP_UPDATE_3D: "// &
128  "optional argument tile_count should be present when number of tiles on this pe is more than 1")
129  tile = tile_count
130  end if
131 
132  do_update = (tile == ntile) .AND. is_complete
133 
134  list = list+1
135  if(list > MAX_DOMAIN_FIELDS)then
136  write( text,'(i2)' ) MAX_DOMAIN_FIELDS
137  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' )
138  endif
139  f_addrs(list,tile) = LOC(field)
140  ke_list(list,tile) = size(field,3)
141 
142  !make sure the field is not called mpp_start_update_domains. Currently we only check the address at tile = 1.
143  if( tile == 1 ) then
144  do n = 1, current_id_update
145  do l = 1, nonblock_data(n)%nfields
146  if( f_addrs(list,tile) == nonblock_data(n)%field_addrs(l)) then
147  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_3D is called again before calling ' //&
148  'mpp_complte_UPDATE_DOMAINS_3D for field '//trim(field_name))
149  endif
150  enddo
151  enddo
152  endif
153 
154  if(list == 1 .AND. tile == 1 )then
155  isize=size(field,1); jsize=size(field,2); pos = update_position
156  whalosz = update_whalo; ehalosz = update_ehalo; shalosz = update_shalo; nhalosz = update_nhalo
157  update_flags_saved = update_flags
158  else
159  set_mismatch = .false.
160  set_mismatch = set_mismatch .OR. (isize /= size(field,1))
161  set_mismatch = set_mismatch .OR. (jsize /= size(field,2))
162  set_mismatch = set_mismatch .OR. (update_position /= pos)
163  set_mismatch = set_mismatch .OR. (update_whalo /= whalosz)
164  set_mismatch = set_mismatch .OR. (update_ehalo /= ehalosz)
165  set_mismatch = set_mismatch .OR. (update_shalo /= shalosz)
166  set_mismatch = set_mismatch .OR. (update_nhalo /= nhalosz)
167  set_mismatch = set_mismatch .OR. (update_flags_saved /= update_flags)
168  if(set_mismatch)then
169  write( text,'(i2)' ) list
170  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS: Incompatible field at count '//text//' for group update.' )
171  endif
172  endif
173 
174  if(is_complete) then
175  l_size = list
176  list = 0
177  end if
178 
179  if(do_update) then
180  if(num_nonblock_group_update>0) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS: "// &
181  " can not be called in the middle of mpp_start_group_update/mpp_complete_group_update call")
182 
183  num_update = num_update + 1
184  if( PRESENT(update_id) ) then
185  if( update_id < 1 .OR. update_id > MAX_NONBLOCK_UPDATE ) then
186  write( text,'(a,i8,a,i8)' ) 'optional argument update_id =', update_id, &
187  'is less than 1 or greater than MAX_NONBLOCK_UPDATE =', MAX_NONBLOCK_UPDATE
188  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS: '//trim(text))
189  endif
190  current_id = update_id
191  reuse_id_update = .true.
192  !--- when reuse the update_id, make sure update_flag, halo size and update_position are still the same
193  if( nonblock_data(current_id)%update_flags .NE. update_flags .OR. &
194  nonblock_data(current_id)%update_whalo .NE. update_whalo .OR. &
195  nonblock_data(current_id)%update_ehalo .NE. update_ehalo .OR. &
196  nonblock_data(current_id)%update_shalo .NE. update_shalo .OR. &
197  nonblock_data(current_id)%update_nhalo .NE. update_nhalo .OR. &
198  nonblock_data(current_id)%update_position .NE. update_position ) then
199  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS: mismatch for optional argument for field '//trim(field_name) )
200  endif
201  else
202  reuse_id_update = .false.
203  current_id_update = current_id_update + 1
204  if( current_id_update > MAX_NONBLOCK_UPDATE ) then
205  write( text,'(a,i8,a,i8)' ) 'num_fields =', current_id_update, &
206  ' greater than MAX_NONBLOCK_UPDATE =', MAX_NONBLOCK_UPDATE
207  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS: '//trim(text))
208  endif
209  current_id = current_id_update
210  nonblock_data(current_id)%update_flags = update_flags
211  nonblock_data(current_id)%update_whalo = update_whalo
212  nonblock_data(current_id)%update_ehalo = update_ehalo
213  nonblock_data(current_id)%update_shalo = update_shalo
214  nonblock_data(current_id)%update_nhalo = update_nhalo
215  nonblock_data(current_id)%update_position = update_position
216  nonblock_data(current_id)%recv_pos = nonblock_buffer_pos
217  endif
218  nonblock_data(current_id)%nfields = l_size
219  nonblock_data(current_id)%field_addrs(1:l_size) = f_addrs(1:l_size,1)
220  MPP_START_UPDATE_DOMAINS_3D_ = current_id
221 
222  ke_max = maxval(ke_list(1:l_size,1:ntile))
223  if( domain_update_is_needed(domain, update_whalo, update_ehalo, update_shalo, update_nhalo) )then
224  update => search_update_overlap(domain, update_whalo, update_ehalo, update_shalo, update_nhalo, update_position)
225  call mpp_start_do_update(current_id, f_addrs(1:l_size,1:ntile), domain, update, d_type, &
226  ke_max, ke_list(1:l_size,1:ntile), update_flags, reuse_id_update, field_name )
227  endif
228  l_size=0; f_addrs=-9999; isize=0; jsize=0; ke_list=0
229  else
230  if(present(update_id)) then
231  MPP_START_UPDATE_DOMAINS_3D_ = update_id
232  else
233  MPP_START_UPDATE_DOMAINS_3D_ = 0
234  endif
235  endif
236 
237 
238 end function MPP_START_UPDATE_DOMAINS_3D_
239 
240 !##########################################################################################
241 function MPP_START_UPDATE_DOMAINS_4D_( field, domain, flags, position, &
242  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete )
243  type(domain2D), intent(inout) :: domain
244  MPP_TYPE_, intent(inout) :: field(:,:,:,:)
245  integer, intent(in), optional :: flags
246  integer, intent(in), optional :: position
247  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated.
248  character(len=*), intent(in), optional :: name
249  integer, intent(in), optional :: tile_count
250  integer, intent(in), optional :: update_id
251  logical, intent(in), optional :: complete
252  integer :: MPP_START_UPDATE_DOMAINS_4D_
253 
254  MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4))
255  pointer( ptr, field3D )
256  ptr = LOC(field)
257 
258  MPP_START_UPDATE_DOMAINS_4D_ = mpp_start_update_domains(field3D, domain, flags, position, &
259  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete)
260  return
261 
262 end function MPP_START_UPDATE_DOMAINS_4D_
263 
264 !##########################################################################################
265 function MPP_START_UPDATE_DOMAINS_5D_( field, domain, flags, position, &
266  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete)
267  type(domain2D), intent(inout) :: domain
268  MPP_TYPE_, intent(inout) :: field(:,:,:,:,:)
269  integer, intent(in), optional :: flags
270  integer, intent(in), optional :: position
271  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated.
272  character(len=*), intent(in), optional :: name
273  integer, intent(in), optional :: tile_count
274  integer, intent(in), optional :: update_id
275  logical, intent(in), optional :: complete
276  integer :: MPP_START_UPDATE_DOMAINS_5D_
277 
278  MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5))
279  pointer( ptr, field3D )
280  ptr = LOC(field)
281 
282  MPP_START_UPDATE_DOMAINS_5D_ = mpp_start_update_domains(field3D, domain, flags, position, &
283  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete )
284  return
285 
286 end function MPP_START_UPDATE_DOMAINS_5D_
287 
288 !##################################################################################
289 subroutine MPP_COMPLETE_UPDATE_DOMAINS_2D_( id_update, field, domain, flags, position, &
290  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
291  integer, intent(in) :: id_update
292  type(domain2D), intent(inout) :: domain
293  MPP_TYPE_, intent(inout) :: field(:,:)
294  integer, intent(in), optional :: flags
295  integer, intent(in), optional :: position
296  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated.
297  character(len=*), intent(in), optional :: name
298  integer, intent(in), optional :: tile_count
299  logical, intent(in), optional :: complete
300 
301  MPP_TYPE_ :: field3D(size(field,1),size(field,2),1)
302  pointer( ptr, field3D )
303  ptr = LOC(field)
304  call mpp_complete_update_domains(id_update, field3D, domain, flags, position, &
305  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
306 
307 end subroutine MPP_COMPLETE_UPDATE_DOMAINS_2D_
308 
309 !##################################################################################
310 subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_( id_update, field, domain, flags, position, &
311  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
312  integer, intent(in) :: id_update
313  type(domain2D), intent(inout) :: domain
314  MPP_TYPE_, intent(inout) :: field(domain%x(1)%data%begin:,domain%y(1)%data%begin:,:)
315  integer, intent(in), optional :: flags
316  integer, intent(in), optional :: position
317  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated.
318  character(len=*), intent(in), optional :: name
319  integer, intent(in), optional :: tile_count
320  logical, intent(in), optional :: complete
321 
322 
323  integer :: update_whalo, update_ehalo, update_shalo, update_nhalo
324  integer :: update_position, update_flags
325  type(overlapSpec), pointer :: update => NULL()
326  integer :: tile, max_ntile, ntile, n
327  logical :: is_complete
328  logical :: do_update
329  integer :: ke_max
330  integer, save :: list=0, l_size=0
331  integer, save :: ke_list(MAX_DOMAIN_FIELDS, MAX_TILES)=0
332  integer(LONG_KIND), save :: f_addrs(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999
333  character(len=128) :: text
334  MPP_TYPE_ :: d_type
335 
336  if(present(whalo)) then
337  update_whalo = whalo
338  if(abs(update_whalo) > domain%whalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
339  "optional argument whalo should not be larger than the whalo when define domain.")
340  else
341  update_whalo = domain%whalo
342  end if
343  if(present(ehalo)) then
344  update_ehalo = ehalo
345  if(abs(update_ehalo) > domain%ehalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
346  "optional argument ehalo should not be larger than the ehalo when define domain.")
347  else
348  update_ehalo = domain%ehalo
349  end if
350  if(present(shalo)) then
351  update_shalo = shalo
352  if(abs(update_shalo) > domain%shalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
353  "optional argument shalo should not be larger than the shalo when define domain.")
354  else
355  update_shalo = domain%shalo
356  end if
357  if(present(nhalo)) then
358  update_nhalo = nhalo
359  if(abs(update_nhalo) > domain%nhalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
360  "optional argument nhalo should not be larger than the nhalo when define domain.")
361  else
362  update_nhalo = domain%nhalo
363  end if
364 
365  update_position = CENTER
366  if(present(position)) update_position = position
367  update_flags = XUPDATE+YUPDATE !default
368  if( PRESENT(flags) )update_flags = flags
369 
370  max_ntile = domain%max_ntile_pe
371  ntile = size(domain%x(:))
372  is_complete = .true.
373  if(PRESENT(complete)) then
374  is_complete = complete
375  end if
376  tile = 1
377 
378  if(max_ntile>1) then
379  if(ntile>MAX_TILES) then
380  write( text,'(i2)' ) MAX_TILES
381  call mpp_error(FATAL,'MPP_COMPLETE_UPDATE_DOMAINS_3D: MAX_TILES='//text//' is less than number of tiles on this pe.' )
382  endif
383  if(.NOT. present(tile_count) ) call mpp_error(FATAL, "MPP_UPDATE_3D: "// &
384  "optional argument tile_count should be present when number of tiles on this pe is more than 1")
385  tile = tile_count
386  end if
387  do_update = (tile == ntile) .AND. is_complete
388  list = list+1
389  if(list > MAX_DOMAIN_FIELDS)then
390  write( text,'(i2)' ) MAX_DOMAIN_FIELDS
391  call mpp_error(FATAL,'MPP_COMPLETE_UPDATE_DOMAINS_3D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' )
392  endif
393  f_addrs(list, tile) = LOC(field)
394  !-- make sure the f_addrs match the one at mpp_start_update_domains
395  if( tile == 1 ) then
396  if( nonblock_data(id_update)%field_addrs(list) .NE. f_addrs(list, tile)) then
397  call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
398  "mismatch of address between mpp_start_update_domains and mpp_complete_update_domains")
399  endif
400  endif
401 
402  ke_list(list,tile) = size(field,3)
403 
404  !check to make sure the consistency of halo size, position and flags.
405  if( nonblock_data(id_update)%update_flags .NE. update_flags ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
406  "mismatch of optional argument flag between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
407  if( nonblock_data(id_update)%update_whalo .NE. update_whalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
408  "mismatch of optional argument whalo between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
409  if( nonblock_data(id_update)%update_ehalo .NE. update_ehalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
410  "mismatch of optional argument ehalo between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
411  if( nonblock_data(id_update)%update_shalo .NE. update_shalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
412  "mismatch of optional argument shalo between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
413  if( nonblock_data(id_update)%update_nhalo .NE. update_nhalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
414  "mismatch of optional argument nhalo between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
415  if( nonblock_data(id_update)%update_position .NE. update_position ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
416  "mismatch of optional argument position between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
417 
418  if(is_complete) then
419  l_size = list
420  list = 0
421  end if
422 
423  if(do_update) then
424  if(l_size .NE. nonblock_data(id_update)%nfields) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D: "// &
425  "mismatch of number of fields between mpp_start_update_domains and mpp_complete_update_domains")
426  num_update = num_update - 1
427  if( domain_update_is_needed(domain, update_whalo, update_ehalo, update_shalo, update_nhalo) ) then
428  update => search_update_overlap(domain, update_whalo, update_ehalo, update_shalo, update_nhalo, update_position)
429  ke_max = maxval(ke_list(1:l_size,1:ntile))
430  call mpp_complete_do_update(id_update, f_addrs(1:l_size,1:ntile), domain, update, d_type, &
431  ke_max, ke_list(1:l_size,1:ntile), update_flags)
432  endif
433  nonblock_data(id_update)%nfields = 0
434  nonblock_data(id_update)%field_addrs(1:l_size) = 0
435  l_size=0; f_addrs=-9999; ke_list=0
436  !--- For the last call of mpp_complete_update_domains
437  !--- reset everything to init state
438  if( num_update == 0) then
439  do n = 1, current_id_update
440  call init_nonblock_type(nonblock_data(n))
441  enddo
442  current_id_update = 0
443  nonblock_buffer_pos = 0
444  endif
445  endif
446 
447 end subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_
448 
449 !##################################################################################
450 subroutine MPP_COMPLETE_UPDATE_DOMAINS_4D_( id_update, field, domain, flags, position, &
451  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
452  integer, intent(in) :: id_update
453  type(domain2D), intent(inout) :: domain
454  MPP_TYPE_, intent(inout) :: field(:,:,:,:)
455  integer, intent(in), optional :: flags
456  integer, intent(in), optional :: position
457  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated.
458  character(len=*), intent(in), optional :: name
459  integer, intent(in), optional :: tile_count
460  logical, intent(in), optional :: complete
461 
462  MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4))
463  pointer( ptr, field3D )
464  ptr = LOC(field)
465  call mpp_complete_update_domains(id_update, field3D, domain, flags, position, &
466  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
467 
468 end subroutine MPP_COMPLETE_UPDATE_DOMAINS_4D_
469 
470 !##################################################################################
471 subroutine MPP_COMPLETE_UPDATE_DOMAINS_5D_( id_update, field, domain, flags, position, &
472  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
473  integer, intent(in) :: id_update
474  type(domain2D), intent(inout) :: domain
475  MPP_TYPE_, intent(inout) :: field(:,:,:,:,:)
476  integer, intent(in), optional :: flags
477  integer, intent(in), optional :: position
478  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated.
479  character(len=*), intent(in), optional :: name
480  integer, intent(in), optional :: tile_count
481  logical, intent(in), optional :: complete
482 
483  MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5))
484  pointer( ptr, field3D )
485  ptr = LOC(field)
486  call mpp_complete_update_domains(id_update, field3D, domain, flags, position, &
487  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
488 
489 end subroutine MPP_COMPLETE_UPDATE_DOMAINS_5D_
490 
491 #ifdef VECTOR_FIELD_
492 function MPP_START_UPDATE_DOMAINS_2D_V_( fieldx, fieldy, domain, flags, gridtype, &
493  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete )
494  !updates data domain of 3D field whose computational domains have been computed
495  MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:)
496  type(domain2D), intent(inout) :: domain
497  integer, intent(in), optional :: flags, gridtype
498  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
499  character(len=*), intent(in), optional :: name
500  integer, intent(in), optional :: tile_count
501  integer, intent(in), optional :: update_id
502  logical, intent(in), optional :: complete
503  integer :: MPP_START_UPDATE_DOMAINS_2D_V_
504  MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1)
505  MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1)
506  pointer( ptrx, field3Dx )
507  pointer( ptry, field3Dy )
508  ptrx = LOC(fieldx)
509  ptry = LOC(fieldy)
510 
511  MPP_START_UPDATE_DOMAINS_2D_V_ = mpp_start_update_domains(field3Dx, field3Dy, domain, flags, gridtype, &
512  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete )
513 
514  return
515 
516 end function MPP_START_UPDATE_DOMAINS_2D_V_
517 
518 !###################################################################################
519 function MPP_START_UPDATE_DOMAINS_3D_V_( fieldx, fieldy, domain, flags, gridtype, &
520  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete )
521  !updates data domain of 3D field whose computational domains have been computed
522  MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:)
523  type(domain2D), intent(inout) :: domain
524  integer, intent(in), optional :: flags, gridtype
525  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
526  character(len=*), intent(in), optional :: name
527  integer, intent(in), optional :: tile_count
528  integer, intent(in), optional :: update_id
529  logical, intent(in), optional :: complete
530  !--- local variables
531  integer :: MPP_START_UPDATE_DOMAINS_3D_V_
532  integer :: update_whalo, update_ehalo, update_shalo, update_nhalo
533  integer :: grid_offset_type, position_x, position_y, update_flags, current_id
534  logical :: do_update, is_complete, set_mismatch
535  integer :: ntile, max_ntile, tile, ke_max, n, l
536  logical :: exchange_uv, reuse_id_update
537  character(len=128) :: text, field_name
538  integer, save :: whalosz, ehalosz, shalosz, nhalosz
539  integer, save :: isize(2)=0,jsize(2)=0,l_size=0, offset_type=0, list=0
540  integer, save :: ke_list (MAX_DOMAIN_FIELDS, MAX_TILES)=0
541  integer(LONG_KIND), save :: f_addrsx(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999
542  integer(LONG_KIND), save :: f_addrsy(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999
543  type(overlapSpec), pointer :: updatex => NULL()
544  type(overlapSpec), pointer :: updatey => NULL()
545  MPP_TYPE_ :: d_type
546 
547  field_name = "unknown"
548  if(present(name)) field_name = name
549 
550  if(present(whalo)) then
551  update_whalo = whalo
552  if(abs(update_whalo) > domain%whalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D_V: "// &
553  "optional argument whalo should not be larger than the whalo when define domain.")
554  else
555  update_whalo = domain%whalo
556  end if
557  if(present(ehalo)) then
558  update_ehalo = ehalo
559  if(abs(update_ehalo) > domain%ehalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D_V: "// &
560  "optional argument ehalo should not be larger than the ehalo when define domain.")
561  else
562  update_ehalo = domain%ehalo
563  end if
564  if(present(shalo)) then
565  update_shalo = shalo
566  if(abs(update_shalo) > domain%shalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D_V: "// &
567  "optional argument shalo should not be larger than the shalo when define domain.")
568  else
569  update_shalo = domain%shalo
570  end if
571  if(present(nhalo)) then
572  update_nhalo = nhalo
573  if(abs(update_nhalo) > domain%nhalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D_V: "// &
574  "optional argument nhalo should not be larger than the nhalo when define domain.")
575  else
576  update_nhalo = domain%nhalo
577  end if
578 
579  grid_offset_type = AGRID
580  if( PRESENT(gridtype) ) grid_offset_type = gridtype
581 
582  update_flags = XUPDATE+YUPDATE !default
583  if( PRESENT(flags) ) then
584  update_flags = flags
585  ! The following test is so that SCALAR_PAIR can be used alone with the
586  ! same default update pattern as without.
587  if (BTEST(update_flags,SCALAR_BIT)) then
588  if (.NOT.(BTEST(update_flags,WEST) .OR. BTEST(update_flags,EAST) &
589  .OR. BTEST(update_flags,NORTH) .OR. BTEST(update_flags,SOUTH))) &
590  update_flags = update_flags + XUPDATE+YUPDATE !default with SCALAR_PAIR
591  end if
592  end if
593 
594  if( BTEST(update_flags,NORTH) .AND. BTEST(domain%fold,NORTH) .AND. BTEST(grid_offset_type,SOUTH) ) &
595  call mpp_error( FATAL, 'MPP_START_UPDATE_DOMAINS_V: Incompatible grid offset and fold.' )
596 
597  max_ntile = domain%max_ntile_pe
598  ntile = size(domain%x(:))
599 
600  is_complete = .true.
601  if(PRESENT(complete)) then
602  is_complete = complete
603  end if
604  tile = 1
605 
606  if(max_ntile>1) then
607  if(ntile>MAX_TILES) then
608  write( text,'(i2)' ) MAX_TILES
609  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_V: MAX_TILES='//text//' is less than number of tiles on this pe.' )
610  endif
611  if(.NOT. present(tile_count) ) call mpp_error(FATAL, "MPP_UPDATE_3D_V: "// &
612  "optional argument tile_count should be present when number of tiles on some pe is more than 1")
613  tile = tile_count
614  end if
615 
616  do_update = (tile == ntile) .AND. is_complete
617  list = list+1
618  if(list > MAX_DOMAIN_FIELDS)then
619  write( text,'(i2)' ) MAX_DOMAIN_FIELDS
620  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' )
621  endif
622 
623  f_addrsx(list, tile) = LOC(fieldx)
624  f_addrsy(list, tile) = LOC(fieldy)
625 
626  if( tile == 1 ) then
627  do n = 1, current_id_update
628  do l = 1, nonblock_data(n)%nfields
629  if( f_addrsx(list,tile) == nonblock_data(n)%field_addrs(l) .OR. &
630  f_addrsy(list,tile) == nonblock_data(n)%field_addrs2(l)) then
631  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_V is called again before calling ' //&
632  'mpp_complte_UPDATE_DOMAINS_V for field '//trim(field_name))
633  endif
634  enddo
635  enddo
636  endif
637 
638  ke_list(list, tile) = size(fieldx,3)
639 
640  if(list == 1 .AND. tile == 1)then
641  isize(1)=size(fieldx,1); jsize(1)=size(fieldx,2)
642  isize(2)=size(fieldy,1); jsize(2)=size(fieldy,2)
643  offset_type = grid_offset_type
644  whalosz = update_whalo; ehalosz = update_ehalo; shalosz = update_shalo; nhalosz = update_nhalo
645  else
646  set_mismatch = .false.
647  set_mismatch = set_mismatch .OR. (isize(1) /= size(fieldx,1))
648  set_mismatch = set_mismatch .OR. (jsize(1) /= size(fieldx,2))
649  set_mismatch = set_mismatch .OR. (isize(2) /= size(fieldy,1))
650  set_mismatch = set_mismatch .OR. (jsize(2) /= size(fieldy,2))
651  set_mismatch = set_mismatch .OR. (grid_offset_type /= offset_type)
652  set_mismatch = set_mismatch .OR. (update_whalo /= whalosz)
653  set_mismatch = set_mismatch .OR. (update_ehalo /= ehalosz)
654  set_mismatch = set_mismatch .OR. (update_shalo /= shalosz)
655  set_mismatch = set_mismatch .OR. (update_nhalo /= nhalosz)
656  if(set_mismatch)then
657  write( text,'(i2)' ) list
658  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_V: Incompatible field at count '//text//' for group vector update.' )
659  end if
660  end if
661  if(is_complete) then
662  l_size = list
663  list = 0
664  end if
665  if(do_update)then
666  if(num_nonblock_group_update>0) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_V: "// &
667  " can not be called in the middle of mpp_start_group_update/mpp_complete_group_update call")
668  num_update = num_update + 1
669  if( PRESENT(update_id) ) then
670  reuse_id_update = .true.
671  if( update_id < 1 .OR. update_id > MAX_NONBLOCK_UPDATE ) then
672  write( text,'(a,i8,a,i8)' ) 'optional argument update_id =', update_id, &
673  'is less than 1 or greater than MAX_NONBLOCK_UPDATE =', MAX_NONBLOCK_UPDATE
674  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_V: '//trim(text))
675  endif
676  current_id = update_id
677  !--- when reuse the update_id, make sure update_flag, halo size and update_position are still the same
678  if( nonblock_data(current_id)%update_flags .NE. update_flags .OR. &
679  nonblock_data(current_id)%update_whalo .NE. update_whalo .OR. &
680  nonblock_data(current_id)%update_ehalo .NE. update_ehalo .OR. &
681  nonblock_data(current_id)%update_shalo .NE. update_shalo .OR. &
682  nonblock_data(current_id)%update_nhalo .NE. update_nhalo .OR. &
683  nonblock_data(current_id)%update_gridtype .NE. grid_offset_type ) then
684  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_V: mismatch for optional argument for field '//trim(field_name) )
685  endif
686  else
687  reuse_id_update = .false.
688  current_id_update = current_id_update + 1
689  current_id = current_id_update
690  if( current_id_update > MAX_NONBLOCK_UPDATE ) then
691  write( text,'(a,i8,a,i8)' ) 'num_fields =', current_id_update, ' greater than MAX_NONBLOCK_UPDATE =', MAX_NONBLOCK_UPDATE
692  call mpp_error(FATAL,'MPP_START_UPDATE_DOMAINS_V: '//trim(text))
693  endif
694  nonblock_data(current_id)%update_flags = update_flags
695  nonblock_data(current_id)%update_whalo = update_whalo
696  nonblock_data(current_id)%update_ehalo = update_ehalo
697  nonblock_data(current_id)%update_shalo = update_shalo
698  nonblock_data(current_id)%update_nhalo = update_nhalo
699  nonblock_data(current_id)%update_gridtype = grid_offset_type
700  nonblock_data(current_id)%recv_pos = nonblock_buffer_pos
701  endif
702  nonblock_data(current_id)%nfields = l_size
703  nonblock_data(current_id)%field_addrs(1:l_size) = f_addrsx(1:l_size,1)
704  nonblock_data(current_id)%field_addrs2(1:l_size) = f_addrsy(1:l_size,1)
705  MPP_START_UPDATE_DOMAINS_3D_V_ = current_id
706  if( domain_update_is_needed(domain, update_whalo, update_ehalo, update_shalo, update_nhalo) )then
707  exchange_uv = .false.
708  if(grid_offset_type == DGRID_NE) then
709  exchange_uv = .true.
710  grid_offset_type = CGRID_NE
711  else if( grid_offset_type == DGRID_SW ) then
712  exchange_uv = .true.
713  grid_offset_type = CGRID_SW
714  end if
715 
716  select case(grid_offset_type)
717  case (AGRID)
718  position_x = CENTER
719  position_y = CENTER
720  case (BGRID_NE, BGRID_SW)
721  position_x = CORNER
722  position_y = CORNER
723  case (CGRID_NE, CGRID_SW)
724  position_x = EAST
725  position_y = NORTH
726  case default
727  call mpp_error(FATAL, "mpp_update_domains2D_nonblock.h: invalid value of grid_offset_type")
728  end select
729  updatex => search_update_overlap(domain, update_whalo, update_ehalo, update_shalo, update_nhalo, position_x)
730  updatey => search_update_overlap(domain, update_whalo, update_ehalo, update_shalo, update_nhalo, position_y)
731 
732  ke_max = maxval(ke_list(1:l_size,1:ntile))
733  if(exchange_uv) then
734  call mpp_start_do_update(current_id, f_addrsx(1:l_size,1:ntile), f_addrsy(1:l_size,1:ntile), domain, &
735  updatey, updatex, d_type, ke_max, ke_list(1:l_size,1:ntile), grid_offset_type, &
736  update_flags, reuse_id_update, field_name)
737  else
738  call mpp_start_do_update(current_id, f_addrsx(1:l_size,1:ntile), f_addrsy(1:l_size,1:ntile), domain, &
739  updatex, updatey, d_type, ke_max, ke_list(1:l_size,1:ntile), grid_offset_type, &
740  update_flags, reuse_id_update, field_name)
741  endif
742  endif
743  l_size=0; f_addrsx=-9999; f_addrsy=-9999; isize=0; jsize=0; ke_list=0
744  else
745  if(present(update_id)) then
746  MPP_START_UPDATE_DOMAINS_3D_V_ = update_id
747  else
748  MPP_START_UPDATE_DOMAINS_3D_V_ = 0
749  endif
750  end if
751 
752  return
753 
754 end function MPP_START_UPDATE_DOMAINS_3D_V_
755 
756 function MPP_START_UPDATE_DOMAINS_4D_V_( fieldx, fieldy, domain, flags, gridtype, &
757  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete )
758  !updates data domain of 3D field whose computational domains have been computed
759  MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:)
760  type(domain2D), intent(inout) :: domain
761  integer, intent(in), optional :: flags, gridtype
762  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
763  character(len=*), intent(in), optional :: name
764  integer, intent(in), optional :: tile_count
765  integer, intent(in), optional :: update_id
766  logical, intent(in), optional :: complete
767  integer :: MPP_START_UPDATE_DOMAINS_4D_V_
768  MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4))
769  MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4))
770  pointer( ptrx, field3Dx )
771  pointer( ptry, field3Dy )
772  ptrx = LOC(fieldx)
773  ptry = LOC(fieldy)
774 
775  MPP_START_UPDATE_DOMAINS_4D_V_ = mpp_start_update_domains(field3Dx, field3Dy, domain, flags, gridtype, &
776  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete )
777 
778  return
779 
780 end function MPP_START_UPDATE_DOMAINS_4D_V_
781 
782 function MPP_START_UPDATE_DOMAINS_5D_V_( fieldx, fieldy, domain, flags, gridtype, &
783  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete )
784  !updates data domain of 3D field whose computational domains have been computed
785  MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:)
786  type(domain2D), intent(inout) :: domain
787  integer, intent(in), optional :: flags, gridtype
788  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
789  character(len=*), intent(in), optional :: name
790  integer, intent(in), optional :: tile_count
791  integer, intent(in), optional :: update_id
792  logical, intent(in), optional :: complete
793  integer :: MPP_START_UPDATE_DOMAINS_5D_V_
794  MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)*size(fieldx,5))
795  MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)*size(fieldy,5))
796  pointer( ptrx, field3Dx )
797  pointer( ptry, field3Dy )
798  ptrx = LOC(fieldx)
799  ptry = LOC(fieldy)
800 
801  MPP_START_UPDATE_DOMAINS_5D_V_ = mpp_start_update_domains(field3Dx, field3Dy, domain, flags, gridtype, &
802  whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete )
803 
804  return
805 
806 end function MPP_START_UPDATE_DOMAINS_5D_V_
807 
808 !####################################################################################
809 subroutine MPP_COMPLETE_UPDATE_DOMAINS_2D_V_( id_update, fieldx, fieldy, domain, flags, gridtype, &
810  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
811  !updates data domain of 3D field whose computational domains have been computed
812  integer, intent(in) :: id_update
813  MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:)
814  type(domain2D), intent(inout) :: domain
815  integer, intent(in), optional :: flags, gridtype
816  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
817  character(len=*), intent(in), optional :: name
818  integer, intent(in), optional :: tile_count
819  logical, intent(in), optional :: complete
820 
821  MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1)
822  MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1)
823  pointer( ptrx, field3Dx )
824  pointer( ptry, field3Dy )
825  ptrx = LOC(fieldx)
826  ptry = LOC(fieldy)
827 
828  call mpp_complete_update_domains(id_update, field3Dx, field3Dy, domain, flags, gridtype, &
829  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
830 
831  return
832 
833 end subroutine MPP_COMPLETE_UPDATE_DOMAINS_2D_V_
834 
835 !####################################################################################
836 subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_V_( id_update, fieldx, fieldy, domain, flags, gridtype, &
837  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
838  !updates data domain of 3D field whose computational domains have been computed
839  integer, intent(in) :: id_update
840  MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:)
841  type(domain2D), intent(inout) :: domain
842  integer, intent(in), optional :: flags, gridtype
843  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
844  character(len=*), intent(in), optional :: name
845  integer, intent(in), optional :: tile_count
846  logical, intent(in), optional :: complete
847 
848  integer :: update_whalo, update_ehalo, update_shalo, update_nhalo
849  integer :: grid_offset_type, position_x, position_y, update_flags
850  logical :: do_update, is_complete
851  integer :: ntile, max_ntile, tile, ke_max, n
852  logical :: exchange_uv
853  character(len=128) :: text
854  integer, save :: l_size=0, list=0
855  integer, save :: ke_list (MAX_DOMAIN_FIELDS, MAX_TILES)=0
856  integer(LONG_KIND), save :: f_addrsx(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999
857  integer(LONG_KIND), save :: f_addrsy(MAX_DOMAIN_FIELDS, MAX_TILES)=-9999
858  type(overlapSpec), pointer :: updatex => NULL()
859  type(overlapSpec), pointer :: updatey => NULL()
860  MPP_TYPE_ :: d_type
861 
862  if(present(whalo)) then
863  update_whalo = whalo
864  if(abs(update_whalo) > domain%whalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D_V: "// &
865  "optional argument whalo should not be larger than the whalo when define domain.")
866  else
867  update_whalo = domain%whalo
868  end if
869  if(present(ehalo)) then
870  update_ehalo = ehalo
871  if(abs(update_ehalo) > domain%ehalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D_V: "// &
872  "optional argument ehalo should not be larger than the ehalo when define domain.")
873  else
874  update_ehalo = domain%ehalo
875  end if
876  if(present(shalo)) then
877  update_shalo = shalo
878  if(abs(update_shalo) > domain%shalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D_V: "// &
879  "optional argument shalo should not be larger than the shalo when define domain.")
880  else
881  update_shalo = domain%shalo
882  end if
883  if(present(nhalo)) then
884  update_nhalo = nhalo
885  if(abs(update_nhalo) > domain%nhalo ) call mpp_error(FATAL, "MPP_START_UPDATE_DOMAINS_3D_V: "// &
886  "optional argument nhalo should not be larger than the nhalo when define domain.")
887  else
888  update_nhalo = domain%nhalo
889  end if
890 
891  grid_offset_type = AGRID
892  if( PRESENT(gridtype) ) grid_offset_type = gridtype
893 
894  update_flags = XUPDATE+YUPDATE !default
895  if( PRESENT(flags) ) then
896  update_flags = flags
897  ! The following test is so that SCALAR_PAIR can be used alone with the
898  ! same default update pattern as without.
899  if (BTEST(update_flags,SCALAR_BIT)) then
900  if (.NOT.(BTEST(update_flags,WEST) .OR. BTEST(update_flags,EAST) &
901  .OR. BTEST(update_flags,NORTH) .OR. BTEST(update_flags,SOUTH))) &
902  update_flags = update_flags + XUPDATE+YUPDATE !default with SCALAR_PAIR
903  end if
904  end if
905 
906  !check to make sure the consistency of halo size, position and flags.
907  if( nonblock_data(id_update)%update_flags .NE. update_flags ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D_V: "// &
908  "mismatch of optional argument flag between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
909  if( nonblock_data(id_update)%update_whalo .NE. update_whalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D_V: "// &
910  "mismatch of optional argument whalo between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
911  if( nonblock_data(id_update)%update_ehalo .NE. update_ehalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D_V: "// &
912  "mismatch of optional argument ehalo between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
913  if( nonblock_data(id_update)%update_shalo .NE. update_shalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D_V: "// &
914  "mismatch of optional argument shalo between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
915  if( nonblock_data(id_update)%update_nhalo .NE. update_nhalo ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D_V: "// &
916  "mismatch of optional argument nhalo between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
917  if( nonblock_data(id_update)%update_gridtype .NE. grid_offset_type ) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_3D_V: "// &
918  "mismatch of optional argument gridtype between MPP_COMPLETE_UPDATE_DOMAINS and MPP_START_UPDATE_DOMAINS")
919 
920  max_ntile = domain%max_ntile_pe
921  ntile = size(domain%x(:))
922 
923  is_complete = .true.
924  if(PRESENT(complete)) then
925  is_complete = complete
926  end if
927  tile = 1
928 
929  if(max_ntile>1) then
930  if(ntile>MAX_TILES) then
931  write( text,'(i2)' ) MAX_TILES
932  call mpp_error(FATAL,'MPP_UPDATE_3D_V: MAX_TILES='//text//' is less than number of tiles on this pe.' )
933  endif
934  if(.NOT. present(tile_count) ) call mpp_error(FATAL, "MPP_UPDATE_3D_V: "// &
935  "optional argument tile_count should be present when number of tiles on some pe is more than 1")
936  tile = tile_count
937  end if
938 
939  do_update = (tile == ntile) .AND. is_complete
940  list = list+1
941  if(list > MAX_DOMAIN_FIELDS)then
942  write( text,'(i2)' ) MAX_DOMAIN_FIELDS
943  call mpp_error(FATAL,'MPP_UPDATE_3D_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' )
944  endif
945 
946  f_addrsx(list, tile) = LOC(fieldx)
947  f_addrsy(list, tile) = LOC(fieldy)
948  !-- make sure the f_addrs match the one at mpp_start_update_domains
949  if( tile == 1 ) then
950  if( nonblock_data(id_update)%field_addrs(list) .NE. f_addrsx(list, tile) .OR. &
951  nonblock_data(id_update)%field_addrs2(list) .NE. f_addrsy(list, tile)) then
952  call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_V: "// &
953  "mismatch of address between mpp_start_update_domains and mpp_complete_update_domains")
954  endif
955  endif
956 
957  ke_list(list, tile) = size(fieldx,3)
958 
959  if(is_complete) then
960  l_size = list
961  list = 0
962  end if
963  if(do_update)then
964  if(l_size .NE. nonblock_data(id_update)%nfields) call mpp_error(FATAL, "MPP_COMPLETE_UPDATE_DOMAINS_V: "// &
965  "mismatch of number of fields between mpp_start_update_domains and mpp_complete_update_domains")
966  num_update = num_update - 1
967  if( domain_update_is_needed(domain, update_whalo, update_ehalo, update_shalo, update_nhalo) )then
968  exchange_uv = .false.
969  if(grid_offset_type == DGRID_NE) then
970  exchange_uv = .true.
971  grid_offset_type = CGRID_NE
972  else if( grid_offset_type == DGRID_SW ) then
973  exchange_uv = .true.
974  grid_offset_type = CGRID_SW
975  end if
976 
977  select case(grid_offset_type)
978  case (AGRID)
979  position_x = CENTER
980  position_y = CENTER
981  case (BGRID_NE, BGRID_SW)
982  position_x = CORNER
983  position_y = CORNER
984  case (CGRID_NE, CGRID_SW)
985  position_x = EAST
986  position_y = NORTH
987  case default
988  call mpp_error(FATAL, "mpp_update_domains2D.h: invalid value of grid_offset_type")
989  end select
990  updatex => search_update_overlap(domain, update_whalo, update_ehalo, update_shalo, update_nhalo, position_x)
991  updatey => search_update_overlap(domain, update_whalo, update_ehalo, update_shalo, update_nhalo, position_y)
992 
993  ke_max = maxval(ke_list(1:l_size,1:ntile))
994  if(exchange_uv) then
995  call mpp_complete_do_update(id_update, f_addrsx(1:l_size,1:ntile), f_addrsy(1:l_size,1:ntile), domain, &
996  updatey, updatex, d_type, ke_max, ke_list(1:l_size,1:ntile), &
997  grid_offset_type, update_flags)
998  else
999  call mpp_complete_do_update(id_update, f_addrsx(1:l_size,1:ntile), f_addrsy(1:l_size,1:ntile), domain, &
1000  updatex, updatey, d_type, ke_max, ke_list(1:l_size,1:ntile), &
1001  grid_offset_type, update_flags)
1002  endif
1003  endif
1004  nonblock_data(id_update)%nfields = 0
1005  nonblock_data(id_update)%field_addrs(1:l_size) = 0
1006  nonblock_data(id_update)%field_addrs2(1:l_size) = 0
1007  l_size=0; f_addrsx=-9999; f_addrsy=-9999; ke_list=0
1008  !--- For the last call of mpp_complete_update_domains
1009  !--- reset everything to init state
1010  if( num_update == 0) then
1011  do n = 1, current_id_update
1012  call init_nonblock_type(nonblock_data(n))
1013  enddo
1014  current_id_update = 0
1015  nonblock_buffer_pos = 0
1016  endif
1017  end if
1018 
1019 
1020 end subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_V_
1021 
1022 !####################################################################################
1023 subroutine MPP_COMPLETE_UPDATE_DOMAINS_4D_V_( id_update, fieldx, fieldy, domain, flags, gridtype, &
1024  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
1025  !updates data domain of 3D field whose computational domains have been computed
1026  integer, intent(in) :: id_update
1027  MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:)
1028  type(domain2D), intent(inout) :: domain
1029  integer, intent(in), optional :: flags, gridtype
1030  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1031  character(len=*), intent(in), optional :: name
1032  integer, intent(in), optional :: tile_count
1033  logical, intent(in), optional :: complete
1034 
1035  MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4))
1036  MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4))
1037  pointer( ptrx, field3Dx )
1038  pointer( ptry, field3Dy )
1039  ptrx = LOC(fieldx)
1040  ptry = LOC(fieldy)
1041 
1042  call mpp_complete_update_domains(id_update, field3Dx, field3Dy, domain, flags, gridtype, &
1043  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
1044 
1045  return
1046 
1047 end subroutine MPP_COMPLETE_UPDATE_DOMAINS_4D_V_
1048 
1049 !####################################################################################
1050 subroutine MPP_COMPLETE_UPDATE_DOMAINS_5D_V_( id_update, fieldx, fieldy, domain, flags, gridtype, &
1051  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
1052  !updates data domain of 3D field whose computational domains have been computed
1053  integer, intent(in) :: id_update
1054  MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:)
1055  type(domain2D), intent(inout) :: domain
1056  integer, intent(in), optional :: flags, gridtype
1057  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1058  character(len=*), intent(in), optional :: name
1059  integer, intent(in), optional :: tile_count
1060  logical, intent(in), optional :: complete
1061 
1062  MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)*size(fieldx,5))
1063  MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)*size(fieldy,5))
1064  pointer( ptrx, field3Dx )
1065  pointer( ptry, field3Dy )
1066  ptrx = LOC(fieldx)
1067  ptry = LOC(fieldy)
1068 
1069  call mpp_complete_update_domains(id_update, field3Dx, field3Dy, domain, flags, gridtype, &
1070  whalo, ehalo, shalo, nhalo, name, tile_count, complete )
1071 
1072  return
1073 
1074 end subroutine MPP_COMPLETE_UPDATE_DOMAINS_5D_V_
1075 
1076 #endif
will
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version will
Definition: mpp_transmit_mpi.h:166
time_interp_external_mod::field
type(ext_fieldtype), dimension(:), pointer, save, private field
Definition: time_interp_external.F90:137
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
not
************************************************************************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_update_domains2D_nonblock.h:4
crtm_lowfrequency_mwssem::n
integer n
Definition: CRTM_LowFrequency_MWSSEM.f90:172
fv3jedi_increment_mod::copy
subroutine, public copy(self, rhs)
Definition: fv3jedi_increment_mod.f90:254
mpp_domains_mod::nonblock_buffer_pos
integer nonblock_buffer_pos
Definition: mpp_domains.F90:620
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::true
integer(long), parameter true
Definition: Binary_File_Utility.f90:61
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
diag_integral_mod::field_name
character(len=max_len_name), dimension(max_num_field) field_name
Definition: diag_integral.F90:273
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
mpp_domains_mod::current_id_update
integer current_id_update
Definition: mpp_domains.F90:617
interpolator_mod::name
character(len=32) name
Definition: interpolator.F90:329
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
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_domains_mod::num_update
integer num_update
Definition: mpp_domains.F90:618
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
data_override_mod::num_fields
integer num_fields
Definition: data_override.F90:152
accoeff_define::one
real(double), parameter one
Definition: ACCoeff_Define.f90:69
type_distribution::received
logical function received(this, seqno)
Definition: m_distribution.f90:72
type_distribution::reset
subroutine reset(this)
Definition: m_distribution.f90:98
fv3jedi_increment_mod::check
subroutine check(self)
Definition: fv3jedi_increment_mod.f90:1932
interpolator_mod::len
integer len
Definition: interpolator.F90:321
xgrid_mod::init
logical init
Definition: xgrid.F90:217
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
fv_timing_nlm_mod::last
type(tms), dimension(nblks), private last
Definition: fv_timing_nlm.F90:50
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)
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
mpp_domains_mod::nonblock_data
type(nonblock_type), dimension(:), allocatable nonblock_data
Definition: mpp_domains.F90:624
external_ic_nlm_mod::tile
integer, save tile
Definition: external_ic_nlm.F90:71
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
xgrid_mod::some
subroutine, public some(xmap, some_arr, grid_id)
Definition: xgrid.F90:3421
fv_climate_nudge_nlm_mod::state
type(var_state_type), dimension(2) state
Definition: fv_climate_nudge_nlm.F90:54
mpp_domains_mod::num_nonblock_group_update
integer num_nonblock_group_update
Definition: mpp_domains.F90:619
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