FV3 Bundle
mpp_update_domains2D_ad.h
Go to the documentation of this file.
1 ! -*-f90-*-
2 !***********************************************************************
3 !* GNU Lesser General Public License
4 !*
5 !* This file is part of the GFDL Flexible Modeling System (FMS).
6 !*
7 !* FMS is free software: you can redistribute it and/or modify it under
8 !* the terms of the GNU Lesser General Public License as published by
9 !* the Free Software Foundation, either version 3 of the License, or (at
10 !* your option) any later version.
11 !*
12 !* FMS is distributed in the hope that it will be useful, but WITHOUT
13 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 !* for more details.
16 !*
17 !* You should have received a copy of the GNU Lesser General Public
18 !* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
19 !***********************************************************************
20  subroutine MPP_UPDATE_DOMAINS_AD_2D_( field, domain, flags, complete, position, &
21  whalo, ehalo, shalo, nhalo, name, tile_count)
22 !updates data domain of 2D field whose computational domains have been computed
23  MPP_TYPE_, intent(inout) :: field(:,:)
24  type(domain2D), intent(inout) :: domain
25  integer, intent(in), optional :: flags
26  logical, intent(in), optional :: complete
27  integer, intent(in), optional :: position
28  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
29  character(len=*), intent(in), optional :: name
30  integer, intent(in), optional :: tile_count
31 
32  MPP_TYPE_ :: field3D(size(field,1),size(field,2),1)
33  pointer( ptr, field3D )
34  ptr = LOC(field)
35  call mpp_update_domains_ad( field3D, domain, flags, complete, position, &
36  whalo, ehalo, shalo, nhalo, name, tile_count )
37  return
38  end subroutine MPP_UPDATE_DOMAINS_AD_2D_
39 
40  subroutine MPP_UPDATE_DOMAINS_AD_3D_( field, domain, flags, complete, position, &
41  whalo, ehalo, shalo, nhalo, name, tile_count)
42 !updates data domain of 3D field whose computational domains have been computed
43  MPP_TYPE_, intent(inout) :: field(:,:,:)
44  type(domain2D), intent(inout) :: domain
45  integer, intent(in), optional :: flags
46  logical, intent(in), optional :: complete
47  integer, intent(in), optional :: position
48  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated.
49  character(len=*), intent(in), optional :: name
50  integer, intent(in), optional :: tile_count
51 
52  integer :: update_position, update_whalo, update_ehalo, update_shalo, update_nhalo, ntile
53 
54  integer(LONG_KIND),dimension(MAX_DOMAIN_FIELDS, MAX_TILES),save :: f_addrs=-9999
55  integer :: tile, max_ntile
56  character(len=3) :: text
57  logical :: set_mismatch, is_complete
58  logical :: do_update
59  integer, save :: isize=0, jsize=0, ke=0, l_size=0, list=0
60  integer, save :: pos, whalosz, ehalosz, shalosz, nhalosz
61  MPP_TYPE_ :: d_type
62  type(overlapSpec), pointer :: update => NULL()
63  type(overlapSpec), pointer :: check => NULL()
64 
65  if(present(whalo)) then
66  update_whalo = whalo
67  if(abs(update_whalo) > domain%whalo ) call mpp_error(FATAL, "MPP_UPDATE_AD_3D: "// &
68  "optional argument whalo should not be larger than the whalo when define domain.")
69  else
70  update_whalo = domain%whalo
71  end if
72  if(present(ehalo)) then
73  update_ehalo = ehalo
74  if(abs(update_ehalo) > domain%ehalo ) call mpp_error(FATAL, "MPP_UPDATE_AD_3D: "// &
75  "optional argument ehalo should not be larger than the ehalo when define domain.")
76  else
77  update_ehalo = domain%ehalo
78  end if
79  if(present(shalo)) then
80  update_shalo = shalo
81  if(abs(update_shalo) > domain%shalo ) call mpp_error(FATAL, "MPP_UPDATE_AD_3D: "// &
82  "optional argument shalo should not be larger than the shalo when define domain.")
83  else
84  update_shalo = domain%shalo
85  end if
86  if(present(nhalo)) then
87  update_nhalo = nhalo
88  if(abs(update_nhalo) > domain%nhalo ) call mpp_error(FATAL, "MPP_UPDATE_AD_3D: "// &
89  "optional argument nhalo should not be larger than the nhalo when define domain.")
90  else
91  update_nhalo = domain%nhalo
92  end if
93 
94  !--- when there is NINETY or MINUS_NINETY rotation for some contact, the salar data can not be on E or N-cell,
95  if(present(position)) then
96  if(domain%rotated_ninety .AND. ( position == EAST .OR. position == NORTH ) ) &
97  call mpp_error(FATAL, 'MPP_UPDATE_AD_3D: hen there is NINETY or MINUS_NINETY rotation, ' // &
98  'can not use scalar version update_domain for data on E or N-cell' )
99  end if
100 
101  max_ntile = domain%max_ntile_pe
102  ntile = size(domain%x(:))
103  is_complete = .true.
104  if(PRESENT(complete)) then
105  is_complete = complete
106  end if
107  tile = 1
108 
109  if(max_ntile>1) then
110  if(ntile>MAX_TILES) then
111  write( text,'(i2)' ) MAX_TILES
112  call mpp_error(FATAL,'MPP_UPDATE_AD_3D: MAX_TILES='//text//' is less than number of tiles on this pe.' )
113  endif
114  if(.NOT. present(tile_count) ) call mpp_error(FATAL, "MPP_UPDATE_AD_3D: "// &
115  "optional argument tile_count should be present when number of tiles on this pe is more than 1")
116  tile = tile_count
117  end if
118  do_update = (tile == ntile) .AND. is_complete
119  list = list+1
120  if(list > MAX_DOMAIN_FIELDS)then
121  write( text,'(i2)' ) MAX_DOMAIN_FIELDS
122  call mpp_error(FATAL,'MPP_UPDATE_AD_3D: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' )
123  endif
124  f_addrs(list, tile) = LOC(field)
125  update_position = CENTER
126  if(present(position)) update_position = position
127  if(list == 1 .AND. tile == 1 )then
128  isize=size(field,1); jsize=size(field,2); ke = size(field,3); pos = update_position
129  whalosz = update_whalo; ehalosz = update_ehalo; shalosz = update_shalo; nhalosz = update_nhalo
130  else
131  set_mismatch = .false.
132  set_mismatch = set_mismatch .OR. (isize /= size(field,1))
133  set_mismatch = set_mismatch .OR. (jsize /= size(field,2))
134  set_mismatch = set_mismatch .OR. (ke /= size(field,3))
135  set_mismatch = set_mismatch .OR. (update_position /= pos)
136  set_mismatch = set_mismatch .OR. (update_whalo /= whalosz)
137  set_mismatch = set_mismatch .OR. (update_ehalo /= ehalosz)
138  set_mismatch = set_mismatch .OR. (update_shalo /= shalosz)
139  set_mismatch = set_mismatch .OR. (update_nhalo /= nhalosz)
140  if(set_mismatch)then
141  write( text,'(i2)' ) list
142  call mpp_error(FATAL,'MPP_UPDATE_AD_3D: 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  if(do_update )then
150  if( domain_update_is_needed(domain, update_whalo, update_ehalo, update_shalo, update_nhalo) )then
151  if(debug_update_level .NE. NO_CHECK) then
152  check => search_check_overlap(domain, update_position)
153  if(ASSOCIATED(check) ) then
154  call mpp_do_check(f_addrs(1:l_size,1:ntile), domain, check, d_type, ke, flags, name )
155  endif
156  endif
157  update => search_update_overlap(domain, update_whalo, update_ehalo, update_shalo, update_nhalo, update_position)
158 
159  !call mpp_do_update( f_addrs(1:l_size,1:ntile), domain, update, d_type, ke, &
160  ! b_addrs(1:l_size,1:ntile), bsize, flags)
161 
162  if ( PRESENT ( flags ) ) then
163  call mpp_do_update_ad( f_addrs(1:l_size,1:ntile), domain, update, d_type, ke, flags )
164  else
165  call mpp_do_update_ad( f_addrs(1:l_size,1:ntile), domain, update, d_type, ke )
166  endif
167 
168 
169  end if
170  l_size=0; f_addrs=-9999; isize=0; jsize=0; ke=0
171  endif
172  return
173 
174  end subroutine MPP_UPDATE_DOMAINS_AD_3D_
175 
176  subroutine MPP_UPDATE_DOMAINS_AD_4D_( field, domain, flags, complete, position, &
177  whalo, ehalo, shalo, nhalo, name, tile_count )
178 !updates data domain of 4D field whose computational domains have been computed
179  MPP_TYPE_, intent(inout) :: field(:,:,:,:)
180  type(domain2D), intent(inout) :: domain
181  integer, intent(in), optional :: flags
182  logical, intent(in), optional :: complete
183  integer, intent(in), optional :: position
184  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
185  character(len=*), intent(in), optional :: name
186  integer, intent(in), optional :: tile_count
187 
188  MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4))
189  pointer( ptr, field3D )
190  ptr = LOC(field)
191  call mpp_update_domains_ad( field3D, domain, flags, complete, position, &
192  whalo, ehalo, shalo, nhalo, name, tile_count)
193  return
194  end subroutine MPP_UPDATE_DOMAINS_AD_4D_
195 
196  subroutine MPP_UPDATE_DOMAINS_AD_5D_( field, domain, flags, complete, position, &
197  whalo, ehalo, shalo, nhalo, name, tile_count )
198 !updates data domain of 5D field whose computational domains have been computed
199  MPP_TYPE_, intent(inout) :: field(:,:,:,:,:)
200  type(domain2D), intent(inout) :: domain
201  integer, intent(in), optional :: flags
202  logical, intent(in), optional :: complete
203  integer, intent(in), optional :: position
204  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
205  character(len=*), intent(in), optional :: name
206  integer, intent(in), optional :: tile_count
207 
208  MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5))
209 
210  pointer( ptr, field3D )
211  ptr = LOC(field)
212  call mpp_update_domains_ad( field3D, domain, flags, complete, position, &
213  whalo, ehalo, shalo, nhalo, name, tile_count )
214  return
215  end subroutine MPP_UPDATE_DOMAINS_AD_5D_
216 
217 
218 #ifdef VECTOR_FIELD_
219 
220 !VECTOR_FIELD_ is set to false for MPP_TYPE_ integer.
221 !vector fields
222  subroutine MPP_UPDATE_DOMAINS_AD_2D_V_( fieldx, fieldy, domain, flags, gridtype, complete, &
223  whalo, ehalo, shalo, nhalo, name, tile_count)
224 !updates data domain of 2D field whose computational domains have been computed
225  MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:)
226  type(domain2D), intent(inout) :: domain
227  integer, intent(in), optional :: flags, gridtype
228  logical, intent(in), optional :: complete
229  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
230  character(len=*), intent(in), optional :: name
231  integer, intent(in), optional :: tile_count
232 
233  MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),1)
234  MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),1)
235  pointer( ptrx, field3Dx )
236  pointer( ptry, field3Dy )
237  ptrx = LOC(fieldx)
238  ptry = LOC(fieldy)
239  call mpp_update_domains_ad( field3Dx, field3Dy, domain, flags, gridtype, complete, &
240  whalo, ehalo, shalo, nhalo, name, tile_count)
241  return
242  end subroutine MPP_UPDATE_DOMAINS_AD_2D_V_
243 
244 
245  subroutine MPP_UPDATE_DOMAINS_AD_3D_V_( fieldx, fieldy, domain, flags, gridtype, complete, &
246  whalo, ehalo, shalo, nhalo, name, tile_count)
247 !updates data domain of 3D field whose computational domains have been computed
248  MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:)
249  type(domain2D), intent(inout) :: domain
250  integer, intent(in), optional :: flags, gridtype
251  logical, intent(in), optional :: complete
252  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
253  character(len=*), intent(in), optional :: name
254  integer, intent(in), optional :: tile_count
255 
256  integer :: update_whalo, update_ehalo, update_shalo, update_nhalo, ntile
257  integer :: grid_offset_type
258  logical :: exchange_uv
259 
260  integer(LONG_KIND),dimension(MAX_DOMAIN_FIELDS, MAX_TILES),save :: f_addrsx=-9999, f_addrsy=-9999
261  logical :: do_update, is_complete
262  integer, save :: isize(2)=0,jsize(2)=0,ke=0,l_size=0, offset_type=0, list=0
263  integer, save :: whalosz, ehalosz, shalosz, nhalosz
264  integer :: tile, max_ntile
265  integer :: position_x, position_y
266  logical :: set_mismatch
267  character(len=3) :: text
268  MPP_TYPE_ :: d_type
269  type(overlapSpec), pointer :: updatex => NULL()
270  type(overlapSpec), pointer :: updatey => NULL()
271  type(overlapSpec), pointer :: checkx => NULL()
272  type(overlapSpec), pointer :: checky => NULL()
273 
274  if(present(whalo)) then
275  update_whalo = whalo
276  if(abs(update_whalo) > domain%whalo ) call mpp_error(FATAL, "MPP_UPDATE_AD_3D_V: "// &
277  "optional argument whalo should not be larger than the whalo when define domain.")
278  else
279  update_whalo = domain%whalo
280  end if
281  if(present(ehalo)) then
282  update_ehalo = ehalo
283  if(abs(update_ehalo) > domain%ehalo ) call mpp_error(FATAL, "MPP_UPDATE_AD_3D_V: "// &
284  "optional argument ehalo should not be larger than the ehalo when define domain.")
285  else
286  update_ehalo = domain%ehalo
287  end if
288  if(present(shalo)) then
289  update_shalo = shalo
290  if(abs(update_shalo) > domain%shalo ) call mpp_error(FATAL, "MPP_UPDATE_AD_3D_V: "// &
291  "optional argument shalo should not be larger than the shalo when define domain.")
292  else
293  update_shalo = domain%shalo
294  end if
295  if(present(nhalo)) then
296  update_nhalo = nhalo
297  if(abs(update_nhalo) > domain%nhalo ) call mpp_error(FATAL, "MPP_UPDATE_AD_3D_V: "// &
298  "optional argument nhalo should not be larger than the nhalo when define domain.")
299  else
300  update_nhalo = domain%nhalo
301  end if
302 
303  grid_offset_type = AGRID
304  if( PRESENT(gridtype) ) grid_offset_type = gridtype
305 
306  exchange_uv = .false.
307  if(grid_offset_type == DGRID_NE) then
308  exchange_uv = .true.
309  grid_offset_type = CGRID_NE
310  else if( grid_offset_type == DGRID_SW ) then
311  exchange_uv = .true.
312  grid_offset_type = CGRID_SW
313  end if
314 
315  max_ntile = domain%max_ntile_pe
316  ntile = size(domain%x(:))
317 
318  is_complete = .true.
319  if(PRESENT(complete)) then
320  is_complete = complete
321  end if
322  tile = 1
323 
324  if(max_ntile>1) then
325  if(ntile>MAX_TILES) then
326  write( text,'(i2)' ) MAX_TILES
327  call mpp_error(FATAL,'MPP_UPDATE_AD_3D_V: MAX_TILES='//text//' is less than number of tiles on this pe.' )
328  endif
329  if(.NOT. present(tile_count) ) call mpp_error(FATAL, "MPP_UPDATE_AD_3D_V: "// &
330  "optional argument tile_count should be present when number of tiles on some pe is more than 1")
331  tile = tile_count
332  end if
333 
334  do_update = (tile == ntile) .AND. is_complete
335  list = list+1
336  if(list > MAX_DOMAIN_FIELDS)then
337  write( text,'(i2)' ) MAX_DOMAIN_FIELDS
338  call mpp_error(FATAL,'MPP_UPDATE_AD_3D_V: MAX_DOMAIN_FIELDS='//text//' exceeded for group update.' )
339  endif
340 
341  f_addrsx(list, tile) = LOC(fieldx)
342  f_addrsy(list, tile) = LOC(fieldy)
343 
344  if(list == 1 .AND. tile == 1)then
345  isize(1)=size(fieldx,1); jsize(1)=size(fieldx,2); ke = size(fieldx,3)
346  isize(2)=size(fieldy,1); jsize(2)=size(fieldy,2)
347  offset_type = grid_offset_type
348  whalosz = update_whalo; ehalosz = update_ehalo; shalosz = update_shalo; nhalosz = update_nhalo
349  else
350  set_mismatch = .false.
351  set_mismatch = set_mismatch .OR. (isize(1) /= size(fieldx,1))
352  set_mismatch = set_mismatch .OR. (jsize(1) /= size(fieldx,2))
353  set_mismatch = set_mismatch .OR. (ke /= size(fieldx,3))
354  set_mismatch = set_mismatch .OR. (isize(2) /= size(fieldy,1))
355  set_mismatch = set_mismatch .OR. (jsize(2) /= size(fieldy,2))
356  set_mismatch = set_mismatch .OR. (ke /= size(fieldy,3))
357  set_mismatch = set_mismatch .OR. (grid_offset_type /= offset_type)
358  set_mismatch = set_mismatch .OR. (update_whalo /= whalosz)
359  set_mismatch = set_mismatch .OR. (update_ehalo /= ehalosz)
360  set_mismatch = set_mismatch .OR. (update_shalo /= shalosz)
361  set_mismatch = set_mismatch .OR. (update_nhalo /= nhalosz)
362  if(set_mismatch)then
363  write( text,'(i2)' ) list
364  call mpp_error(FATAL,'MPP_UPDATE_AD_3D_V: Incompatible field at count '//text//' for group vector update.' )
365  end if
366  end if
367  if(is_complete) then
368  l_size = list
369  list = 0
370  end if
371  if(do_update)then
372  if( domain_update_is_needed(domain, update_whalo, update_ehalo, update_shalo, update_nhalo) )then
373  select case(grid_offset_type)
374  case (AGRID)
375  position_x = CENTER
376  position_y = CENTER
377  case (BGRID_NE, BGRID_SW)
378  position_x = CORNER
379  position_y = CORNER
380  case (CGRID_NE, CGRID_SW)
381  position_x = EAST
382  position_y = NORTH
383  case default
384  call mpp_error(FATAL, "mpp_update_domains2D_ad.h: invalid value of grid_offset_type")
385  end select
386 
387  if(debug_update_level .NE. NO_CHECK) then
388  checkx => search_check_overlap(domain, position_x)
389  checky => search_check_overlap(domain, position_y)
390  if(ASSOCIATED(checkx)) then
391  if(exchange_uv) then
392  call mpp_do_check(f_addrsx(1:l_size,1:ntile),f_addrsy(1:l_size,1:ntile), domain, &
393  checky, checkx, d_type, ke, flags, name)
394  else
395  call mpp_do_check(f_addrsx(1:l_size,1:ntile),f_addrsy(1:l_size,1:ntile), domain, &
396  checkx, checky, d_type, ke, flags, name)
397  end if
398  endif
399  endif
400  updatex => search_update_overlap(domain, update_whalo, update_ehalo, update_shalo, update_nhalo, position_x)
401  updatey => search_update_overlap(domain, update_whalo, update_ehalo, update_shalo, update_nhalo, position_y)
402  if(exchange_uv) then
403  call mpp_do_update_ad(f_addrsx(1:l_size,1:ntile),f_addrsy(1:l_size,1:ntile), domain, updatey, updatex, &
404  d_type,ke, grid_offset_type, flags)
405  else
406  call mpp_do_update_ad(f_addrsx(1:l_size,1:ntile),f_addrsy(1:l_size,1:ntile), domain, updatex, updatey, &
407  d_type,ke,grid_offset_type, flags)
408  end if
409  end if
410  l_size=0; f_addrsx=-9999; f_addrsy=-9999; isize=0; jsize=0; ke=0
411  end if
412 
413  return
414  end subroutine MPP_UPDATE_DOMAINS_AD_3D_V_
415 
416 
417  subroutine MPP_UPDATE_DOMAINS_AD_4D_V_( fieldx, fieldy, domain, flags, gridtype, complete, &
418  whalo, ehalo, shalo, nhalo, name, tile_count )
419 !updates data domain of 4D field whose computational domains have been computed
420  MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:)
421  type(domain2D), intent(inout) :: domain
422  integer, intent(in), optional :: flags, gridtype
423  logical, intent(in), optional :: complete
424  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
425  character(len=*), intent(in), optional :: name
426  integer, intent(in), optional :: tile_count
427 
428  MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4))
429  MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4))
430 
431  pointer( ptrx, field3Dx )
432  pointer( ptry, field3Dy )
433  ptrx = LOC(fieldx)
434  ptry = LOC(fieldy)
435  call mpp_update_domains_ad( field3Dx, field3Dy, domain, flags, gridtype, complete, &
436  whalo, ehalo, shalo, nhalo, name, tile_count)
437  return
438  end subroutine MPP_UPDATE_DOMAINS_AD_4D_V_
439 
440  subroutine MPP_UPDATE_DOMAINS_AD_5D_V_( fieldx, fieldy, domain, flags, gridtype, complete, &
441  whalo, ehalo, shalo, nhalo, name, tile_count )
442 !updates data domain of 5D field whose computational domains have been computed
443  MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:)
444  type(domain2D), intent(inout) :: domain
445  integer, intent(in), optional :: flags, gridtype
446  logical, intent(in), optional :: complete
447  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
448  character(len=*), intent(in), optional :: name
449  integer, intent(in), optional :: tile_count
450 
451  MPP_TYPE_ :: field3Dx(size(fieldx,1),size(fieldx,2),size(fieldx,3)*size(fieldx,4)*size(fieldx,5))
452  MPP_TYPE_ :: field3Dy(size(fieldy,1),size(fieldy,2),size(fieldy,3)*size(fieldy,4)*size(fieldy,5))
453  pointer( ptrx, field3Dx )
454  pointer( ptry, field3Dy )
455  ptrx = LOC(fieldx)
456  ptry = LOC(fieldy)
457  call mpp_update_domains_ad( field3Dx, field3Dy, domain, flags, gridtype, complete, &
458  whalo, ehalo, shalo, nhalo, name, tile_count)
459 
460  return
461  end subroutine MPP_UPDATE_DOMAINS_AD_5D_V_
462 #endif /* VECTOR_FIELD_ */
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
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::true
integer(long), parameter true
Definition: Binary_File_Utility.f90:61
field_manager_mod::fields
type(field_mgr_type), dimension(max_fields), private fields
Definition: field_manager.F90:536
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
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
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
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
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:! ***********************************************************************subroutine MPP_UPDATE_DOMAINS_AD_2D_(field, domain, flags, complete, position, &whalo, ehalo, shalo, nhalo, name, tile_count)!updates data domain of 2D field whose computational domains have been computed MPP_TYPE_, intent(inout) ::field(:,:) type(domain2D), intent(inout) ::domain integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::whalo, ehalo, shalo, nhalo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) pointer(ptr, field3D) ptr=LOC(field) call mpp_update_domains_ad(field3D, domain, flags, complete, position, &whalo, ehalo, shalo, nhalo, name, tile_count) return end subroutine MPP_UPDATE_DOMAINS_AD_2D_ subroutine MPP_UPDATE_DOMAINS_AD_3D_(field, domain, flags, complete, position, &whalo, ehalo, shalo, nhalo, name, tile_count)!updates data domain of 3D field whose computational domains have been computed MPP_TYPE_, intent(inout) ::field(:,:,:) type(domain2D), intent(inout) ::domain integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::whalo, ehalo, shalo, nhalo ! specify halo region to be updated. character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count integer ::update_position, update_whalo, update_ehalo, update_shalo, update_nhalo, ntile integer(LONG_KIND), dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save ::f_addrs=-9999 integer ::tile, max_ntile character(len=3) ::text logical ::set_mismatch, is_complete logical ::do_update integer, save ::isize=0, jsize=0, ke=0, l_size=0, list=0 integer, save ::pos, whalosz, ehalosz, shalosz, nhalosz MPP_TYPE_ ::d_type type(overlapSpec), pointer ::update=> NULL() type(overlapSpec)
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
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)
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_update_domains2D_ad.h:5
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
mpp_domains_mod::debug_update_level
integer debug_update_level
Definition: mpp_domains.F90:712