FV3 Bundle
mpp_domains_misc.inc
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 
21 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
22 ! !
23 ! MPP_DOMAINS: initialization and termination !
24 ! !
25 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
26 
27 ! <SUBROUTINE NAME="mpp_domains_init">
28 ! <OVERVIEW>
29 ! Initialize domain decomp package.
30 ! </OVERVIEW>
31 ! <DESCRIPTION>
32 ! Called to initialize the <TT>mpp_domains_mod</TT> package.
33 !
34 ! <TT>flags</TT> can be set to <TT>MPP_VERBOSE</TT> to have
35 ! <TT>mpp_domains_mod</TT> keep you informed of what it's up
36 ! to. <TT>MPP_DEBUG</TT> returns even more information for debugging.
37 !
38 ! <TT>mpp_domains_init</TT> will call <TT>mpp_init</TT>, to make sure
39 ! <LINK SRC="mpp.html"><TT>mpp_mod</TT></LINK> is initialized. (Repeated
40 ! calls to <TT>mpp_init</TT> do no harm, so don't worry if you already
41 ! called it).
42 ! </DESCRIPTION>
43 ! <TEMPLATE>
44 ! call mpp_domains_init(flags)
45 ! </TEMPLATE>
46 ! <IN NAME="flags" TYPE="integer"></IN>
47 ! </SUBROUTINE>
48  subroutine mpp_domains_init(flags)
49  integer, intent(in), optional :: flags
50  integer :: n
51 #ifdef use_libSMA
52  integer :: l=0
53 #endif
54  integer :: unit_begin, unit_end, unit_nml, io_status, unit
55  logical :: opened
56 #ifdef use_libSMA
57  integer(POINTER_KIND) :: ptr_info_var(16)
58  pointer( ptr_info, ptr_info_var )
59 #endif
60 
61  if( module_is_initialized )return
62  call mpp_init(flags) !this is a no-op if already initialized
63  call mpp_pset_init !this is a no-op if already initialized
64  module_is_initialized = .TRUE.
65  pe = mpp_root_pe()
66  unit = stdlog()
67  if( mpp_pe() .EQ.mpp_root_pe() ) write( unit,'(/a)' )'MPP_DOMAINS module '//trim(version)
68 
69  if( PRESENT(flags) )then
70  debug = flags.EQ.MPP_DEBUG
71  verbose = flags.EQ.MPP_VERBOSE .OR. debug
72  domain_clocks_on = flags.EQ.MPP_DOMAIN_TIME
73  end if
74 
75  !--- namelist
76 #ifdef INTERNAL_FILE_NML
77  read (input_nml_file, mpp_domains_nml, iostat=io_status)
78 #else
79  unit_begin = 103
80  unit_end = 512
81  do unit_nml = unit_begin, unit_end
82  inquire( unit_nml,OPENED=opened )
83  if( .NOT.opened )exit
84  end do
85 
86  open(unit_nml,file='input.nml', iostat=io_status)
87  read(unit_nml,mpp_domains_nml,iostat=io_status)
88  close(unit_nml)
89 #endif
90 
91  if (io_status > 0) then
92  call mpp_error(FATAL,'=>mpp_domains_init: Error reading input.nml')
93  endif
94 
95 
96  select case(lowercase(trim(debug_update_domain)))
97  case("none")
98  debug_update_level = NO_CHECK
99  case("fatal")
100  debug_update_level = FATAL
101  case("warning")
102  debug_update_level = WARNING
103  case("note")
104  debug_update_level = NOTe
105  case default
106  call mpp_error(FATAL, "mpp_domains_init: debug_update_level should be 'none', 'fatal', 'warning', or 'note'")
107  end select
108 
109  allocate(nonblock_data(MAX_NONBLOCK_UPDATE))
110 
111  do n = 1, MAX_NONBLOCK_UPDATE
112  call init_nonblock_type(nonblock_data(n))
113  enddo
114 
115  call mpp_domains_set_stack_size(32768) !default, pretty arbitrary
116 #ifdef use_libSMA
117  call mpp_malloc( ptr_info, 16, l )
118 #endif
119 
120 !NULL_DOMAIN is a domaintype that can be used to initialize to undef
121  call mpp_define_null_domain(NULL_DOMAIN1d);
122  call mpp_define_null_domain(NULL_DOMAIN2d);
123  call mpp_define_null_UG_domain(NULL_DOMAINUG)
124 
125  if( domain_clocks_on )then
126  pack_clock = mpp_clock_id( 'Halo pack' )
127  send_clock = mpp_clock_id( 'Halo send' )
128  recv_clock = mpp_clock_id( 'Halo recv' )
129  unpk_clock = mpp_clock_id( 'Halo unpk' )
130  wait_clock = mpp_clock_id( 'Halo wait' )
131  send_pack_clock_nonblock = mpp_clock_id( 'Halo pack and send nonblock' )
132  recv_clock_nonblock = mpp_clock_id( 'Halo recv nonblock' )
133  unpk_clock_nonblock = mpp_clock_id( 'Halo unpk nonblock' )
134  wait_clock_nonblock = mpp_clock_id( 'Halo wait nonblock' )
135  nest_pack_clock = mpp_clock_id( 'nest pack' )
136  nest_send_clock = mpp_clock_id( 'nest send' )
137  nest_recv_clock = mpp_clock_id( 'nest recv' )
138  nest_unpk_clock = mpp_clock_id( 'nest unpk' )
139  nest_wait_clock = mpp_clock_id( 'nest wait' )
140  group_pack_clock = mpp_clock_id( 'group pack' )
141  group_send_clock = mpp_clock_id( 'group send' )
142  group_recv_clock = mpp_clock_id( 'group recv' )
143  group_unpk_clock = mpp_clock_id( 'group unpk' )
144  group_wait_clock = mpp_clock_id( 'group wait' )
145  nonblock_group_pack_clock = mpp_clock_id( 'nonblock group pack' )
146  nonblock_group_send_clock = mpp_clock_id( 'nonblock group send' )
147  nonblock_group_recv_clock = mpp_clock_id( 'nonblock group recv' )
148  nonblock_group_unpk_clock = mpp_clock_id( 'nonblock group unpk' )
149  nonblock_group_wait_clock = mpp_clock_id( 'nonblock group wait' )
150  end if
151  return
152  end subroutine mpp_domains_init
153 
154 !#####################################################################
155 subroutine init_nonblock_type( nonblock_obj )
156  type(nonblock_type), intent(inout) :: nonblock_obj
157 
158 
159  nonblock_obj%recv_pos = 0
160  nonblock_obj%send_pos = 0
161  nonblock_obj%recv_msgsize = 0
162  nonblock_obj%send_msgsize = 0
163  nonblock_obj%update_flags = 0
164  nonblock_obj%update_position = 0
165  nonblock_obj%update_gridtype = 0
166  nonblock_obj%update_whalo = 0
167  nonblock_obj%update_ehalo = 0
168  nonblock_obj%update_shalo = 0
169  nonblock_obj%update_nhalo = 0
170  nonblock_obj%request_send_count = 0
171  nonblock_obj%request_recv_count = 0
172  nonblock_obj%size_recv(:) = 0
173  nonblock_obj%type_recv(:) = 0
174 #ifdef use_libMPI
175  nonblock_obj%request_send(:) = MPI_REQUEST_NULL
176  nonblock_obj%request_recv(:) = MPI_REQUEST_NULL
177 #else
178  nonblock_obj%request_send(:) = 0
179  nonblock_obj%request_recv(:) = 0
180 #endif
181  nonblock_obj%buffer_pos_send(:) = 0
182  nonblock_obj%buffer_pos_recv(:) = 0
183  nonblock_obj%nfields = 0
184  nonblock_obj%field_addrs(:) = 0
185  nonblock_obj%field_addrs2(:) = 0
186 
187  return
188 
189 end subroutine init_nonblock_type
190 
191 !#####################################################################
192 ! <SUBROUTINE NAME="mpp_domains_exit">
193 ! <OVERVIEW>
194 ! Exit <TT>mpp_domains_mod</TT>.
195 ! </OVERVIEW>
196 ! <DESCRIPTION>
197 ! Serves no particular purpose, but is provided should you require to
198 ! re-initialize <TT>mpp_domains_mod</TT>, for some odd reason.
199 ! </DESCRIPTION>
200 ! <TEMPLATE>
201 ! call mpp_domains_exit()
202 ! </TEMPLATE>
203 ! </SUBROUTINE>
204  subroutine mpp_domains_exit()
205  integer :: unit
206  if( .NOT.module_is_initialized )return
207  call mpp_max(mpp_domains_stack_hwm)
208  unit = stdout()
209  if( mpp_pe().EQ.mpp_root_pe() )write( unit,* )'MPP_DOMAINS_STACK high water mark=', mpp_domains_stack_hwm
210  module_is_initialized = .FALSE.
211  return
212  end subroutine mpp_domains_exit
213 
214 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
215 ! !
216 ! MPP_CHECK_FIELD: Check parallel !
217 ! !
218 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
219 ! <SUBROUTINE NAME="mpp_check_field_3D" INTERFACE="mpp_check_field">
220 ! <IN NAME="field_in" TYPE="real, dimension(:,:,:)" > </IN>
221 ! <IN NAME="pelist1, pelist2" TYPE="integer, dimension(:)" > </IN>
222 ! <IN NAME="domain" TYPE="type(domain2d)" > </IN>
223 ! <IN NAME="mesg" TYPE="character(len=*)" > </IN>
224 ! <IN NAME="w_halo, s_halo, e_halo, n_halo" TYPE="integer, optional" > </IN>
225 ! <IN NAME="force_abort" TYPE="logical,optional" > </IN>
226 ! </SUBROUTINE>
227 
228  subroutine mpp_check_field_3D(field_in, pelist1, pelist2, domain, mesg, &
229  w_halo, s_halo, e_halo, n_halo, force_abort, position )
230 ! This routine is used to do parallel checking for 3d data between n and m pe. The comparison is
231 ! is done on pelist2. When size of pelist2 is 1, we can check the halo; otherwise,
232 ! halo can not be checked.
233 
234  real, dimension(:,:,:), intent(in) :: field_in ! field to be checked
235  integer, dimension(:), intent(in) :: pelist1, pelist2 ! pe list for the two groups
236  type(domain2d), intent(in) :: domain ! domain for each pe
237  character(len=*), intent(in) :: mesg ! message to be printed out
238  ! if differences found
239  integer, intent(in), optional :: w_halo, s_halo, e_halo, n_halo
240  ! halo size for west, south, east and north
241  logical, intent(in), optional :: force_abort ! when true, call mpp_error if any difference
242  ! found. default value is false.
243  integer, intent(in), optional :: position ! when domain is symmetry, only value = CENTER is
244  ! implemented.
245 
246  integer :: k
247  character(len=256) :: temp_mesg
248 
249 
250  do k = 1, size(field_in,3)
251  write(temp_mesg, '(a, i3)') trim(mesg)//" at level " , k
252  call mpp_check_field_2d(field_in(:,:,k), pelist1, pelist2, domain, temp_mesg, &
253  w_halo, s_halo, e_halo, n_halo, force_abort, position )
254  enddo
255 
256  end subroutine mpp_check_field_3D
257 
258 
259 !#####################################################################################
260 ! <SUBROUTINE NAME="mpp_check_field_2D" INTERFACE="mpp_check_field">
261 ! <IN NAME="field_in" TYPE="real, dimension(:,:)" > </IN>
262 ! </SUBROUTINE>
263  subroutine mpp_check_field_2d(field_in, pelist1, pelist2, domain, mesg, &
264  w_halo, s_halo, e_halo, n_halo,force_abort, position )
265 ! This routine is used to do parallel checking for 2d data between n and m pe. The comparison is
266 ! is done on pelist2. When size of pelist2 is 1, we can check the halo; otherwise,
267 ! halo can not be checked.
268 
269  real, dimension(:,:), intent(in) :: field_in ! field to be checked
270  integer, dimension(:), intent(in) :: pelist1, pelist2 ! pe list for the two groups
271  type(domain2d), intent(in) :: domain ! domain for each pe
272  character(len=*), intent(in) :: mesg ! message to be printed out
273  ! if differences found
274  integer, intent(in), optional :: w_halo, s_halo, e_halo, n_halo
275  ! halo size for west, south, east and north
276  logical, intent(in), optional :: force_abort ! when, call mpp_error if any difference
277  ! found. default value is false.
278  integer, intent(in), optional :: position ! when domain is symmetry, only value = CENTER is
279  ! implemented.
280 
281  if(present(position)) then
282  if(position .NE. CENTER .AND. domain%symmetry) call mpp_error(FATAL, &
283  'mpp_check_field: when domain is symmetry, only value CENTER is implemented, contact author')
284  endif
285 
286  if(size(pelist2(:)) == 1) then
287  call mpp_check_field_2d_type1(field_in, pelist1, pelist2, domain, mesg, &
288  w_halo, s_halo, e_halo, n_halo, force_abort )
289  else if(size(pelist1(:)) == 1) then
290  call mpp_check_field_2d_type1(field_in, pelist2, pelist1, domain, mesg, &
291  w_halo, s_halo, e_halo, n_halo, force_abort )
292  else if(size(pelist1(:)) .gt. 1 .and. size(pelist2(:)) .gt. 1) then
293  call mpp_check_field_2d_type2(field_in, pelist1, pelist2, domain, mesg, force_abort )
294  else
295  call mpp_error(FATAL, 'mpp_check_field: size of both pelists should be greater than 0')
296  endif
297 
298  end subroutine mpp_check_field_2D
299 
300 
301 !####################################################################################
302 
303  subroutine mpp_check_field_2d_type1(field_in, pelist1, pelist2, domain, mesg, &
304  w_halo, s_halo, e_halo, n_halo,force_abort )
305 ! This routine is used to check field between running on 1 pe (pelist2) and
306 ! n pe(pelist1). The need_to_be_checked data is sent to the pelist2 and All the
307 ! comparison is done on pelist2.
308 
309  real, dimension(:,:), intent(in) :: field_in ! field to be checked
310  integer, dimension(:), intent(in) :: pelist1, pelist2 ! pe list for the two groups
311  type(domain2d), intent(in) :: domain ! domain for each pe
312  character(len=*), intent(in) :: mesg ! message to be printed out
313  ! if differences found
314  integer, intent(in), optional :: w_halo, s_halo, e_halo, n_halo
315  ! halo size for west, south, east and north
316  logical, intent(in), optional :: force_abort ! when, call mpp_error if any difference
317  ! found. default value is false.
318 ! some local data
319 
320  integer :: pe,npes, p
321  integer :: hwest, hsouth, heast, hnorth, isg, ieg, jsg, jeg, xhalo, yhalo
322  integer :: i,j,im,jm,l,is,ie,js,je,isc,iec,jsc,jec,isd,ied,jsd,jed
323  real,dimension(:,:), allocatable :: field1,field2
324  real,dimension(:), allocatable :: send_buffer
325  integer, dimension(4) :: ibounds
326  logical :: check_success, error_exit
327 
328  check_success = .TRUE.
329  error_exit = .FALSE.
330  if(present(force_abort)) error_exit = force_abort
331  hwest = 0; if(present(w_halo)) hwest = w_halo
332  heast = 0; if(present(e_halo)) heast = e_halo
333  hsouth = 0; if(present(s_halo)) hsouth = s_halo
334  hnorth = 0; if(present(n_halo)) hnorth = n_halo
335 
336  pe = mpp_pe ()
337  npes = mpp_npes()
338 
339  call mpp_get_compute_domain(domain, isc, iec, jsc, jec)
340  call mpp_get_data_domain(domain, isd, ied, jsd, jed)
341  call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
342  xhalo = isc - isd
343  yhalo = jsc - jsd
344  !--- need to checked halo size should not be bigger than x_halo or y_halo
345  if(hwest .gt. xhalo .or. heast .gt. xhalo .or. hsouth .gt. yhalo .or. hnorth .gt. yhalo) &
346  call mpp_error(FATAL,'mpp_check_field: '//trim(mesg)//': The halo size is not correct')
347 
348  is = isc - hwest; ie = iec + heast; js = jsc - hsouth; je = jec + hnorth
349  allocate(field2(is:ie,js:je))
350 
351  ! check if the field_in is on compute domain or data domain
352  if((size(field_in,1) .eq. iec-isc+1) .and. (size(field_in,2) .eq. jec-jsc+1)) then
353  !if field_in on compute domain, you can not check halo points
354  if( hwest .ne. 0 .or. heast .ne. 0 .or. hsouth .ne. 0 .or. hnorth .ne. 0 ) &
355  call mpp_error(FATAL,'mpp_check_field: '//trim(mesg)//': field is on compute domain, can not check halo')
356  field2(:,:) = field_in(:,:)
357  else if((size(field_in,1) .eq. ied-isd+1) .and. (size(field_in,2) .eq. jed-jsd+1)) then
358  field2(is:ie,js:je) = field_in(is-isd+1:ie-isd+1,js-jsd+1:je-jsd+1)
359  else if((size(field_in,1) .eq. ieg-isg+1) .and. (size(field_in,2) .eq. jeg-jsg+1)) then
360  if( hwest .ne. 0 .or. heast .ne. 0 .or. hsouth .ne. 0 .or. hnorth .ne. 0 ) &
361  call mpp_error(FATAL,'mpp_check_field: '//trim(mesg)//': field is on compute domain, can not check halo')
362  field2(is:ie,js:je) = field_in(1:ie-is+1,1:je-js+1)
363  else if((size(field_in,1) .eq. ieg-isg+1+2*xhalo) .and. (size(field_in,2) .eq. jeg-jsg+1+2*yhalo)) then
364  field2(is:ie,js:je) = field_in(is-isd+1:ie-isd+1,js-jsd+1:je-jsd+1)
365  else
366  print*, 'on pe ', pe, 'domain: ', isc, iec, jsc, jec, isd, ied, jsd, jed, 'size of field: ', size(field_in,1), size(field_in,2)
367  call mpp_error(FATAL,'mpp_check_field: '//trim(mesg)//':field is not on compute, data or global domain')
368  endif
369 
370  call mpp_sync_self()
371 
372  if(any(pelist1 == pe)) then ! send data to root pe
373 
374  im = ie-is+1; jm=je-js+1
375  allocate(send_buffer(im*jm))
376 
377  ibounds(1) = is; ibounds(2) = ie; ibounds(3) = js; ibounds(4) = je
378  l = 0
379  do i = is,ie
380  do j = js,je
381  l = l+1
382  send_buffer(l) = field2(i,j)
383  enddo
384  enddo
385 ! send the check bounds and data to the root pe
386  ! Force use of "scalar", integer pointer mpp interface
387  call mpp_send(ibounds(1), plen=4, to_pe=pelist2(1), tag=COMM_TAG_1)
388  call mpp_send(send_buffer(1),plen=im*jm, to_pe=pelist2(1), tag=COMM_TAG_2)
389  deallocate(send_buffer)
390 
391  else if(pelist2(1) == pe) then ! receive data and compare
392  do p = pelist1(1), pelist1(size(pelist1(:)))
393  ! Force use of "scalar", integer pointer mpp interface
394  call mpp_recv(ibounds(1), glen=4,from_pe=p, tag=COMM_TAG_1)
395  is = ibounds(1); ie = ibounds(2); js=ibounds(3); je=ibounds(4)
396  im = ie-is+1; jm=je-js+1
397  if(allocated(field1)) deallocate(field1)
398  if(allocated(send_buffer)) deallocate(send_buffer)
399  allocate(field1(is:ie,js:je),send_buffer(im*jm))
400  ! Force use of "scalar", integer pointer mpp interface
401  call mpp_recv(send_buffer(1),glen=im*jm,from_pe=p, tag=COMM_TAG_2)
402  l = 0
403 
404 ! compare here, the comparison criteria can be changed according to need
405  do i = is,ie
406  do j = js,je
407  l = l+1
408  field1(i,j) = send_buffer(l)
409  if(field1(i,j) .ne. field2(i,j)) then
410  ! write to standard output
411  print*,trim(mesg)//": ", i, j, field1(i,j), field2(i,j), field1(i,j) - field2(i,j)
412 ! write(stdout(),'(a,2i,2f)') trim(mesg), i, j, pass_field(i,j), field_check(i,j)
413  check_success = .FALSE.
414  if(error_exit) call mpp_error(FATAL,"mpp_check_field: can not reproduce at this point")
415  endif
416  enddo
417  enddo
418  enddo
419 
420  if(check_success) then
421  print*, trim(mesg)//": ", 'comparison between 1 pe and ', npes-1, ' pes is ok'
422  endif
423  ! release memery
424  deallocate(field1, send_buffer)
425  endif
426 
427  deallocate(field2)
428 
429  call mpp_sync()
430 
431  end subroutine mpp_check_field_2d_type1
432 
433 !####################################################################
434 
435  subroutine mpp_check_field_2d_type2(field_in, pelist1, pelist2, domain, mesg,force_abort)
436 ! This routine is used to check field between running on m pe (root pe) and
437 ! n pe. This routine can not check halo.
438 
439  real, dimension(:,:), intent(in) :: field_in
440  type(domain2d), intent(in) :: domain
441  integer, dimension(:), intent(in) :: pelist1
442  integer, dimension(:), intent(in) :: pelist2
443  character(len=*), intent(in) :: mesg
444  logical, intent(in), optional :: force_abort ! when, call mpp_error if any difference
445  ! found. default value is false.
446 ! some local variables
447  logical :: check_success, error_exit
448  real, dimension(:,:), allocatable :: field1, field2
449  integer :: i, j, pe, npes, isd,ied,jsd,jed, is, ie, js, je
450  type(domain2d) :: domain1, domain2
451 
452  check_success = .TRUE.
453  error_exit = .FALSE.
454  if(present(force_abort)) error_exit = force_abort
455  pe = mpp_pe()
456  npes = mpp_npes()
457  call mpp_sync_self()
458  if(any(pelist1 == pe)) domain1 = domain
459  if(any(pelist2 == pe)) domain2 = domain
460 
461 ! Comparison is made on pelist2.
462  if(any(pelist2 == pe)) then
463  call mpp_get_data_domain(domain2, isd, ied, jsd, jed)
464  call mpp_get_compute_domain(domain2, is, ie, js, je)
465  allocate(field1(isd:ied, jsd:jed),field2(isd:ied, jsd:jed))
466  if((size(field_in,1) .ne. ied-isd+1) .or. (size(field_in,2) .ne. jed-jsd+1)) &
467  call mpp_error(FATAL,'mpp_check_field: input field is not on the data domain')
468  field2(isd:ied, jsd:jed) = field_in(:,:)
469  endif
470 
471 ! broadcast domain
472  call mpp_broadcast_domain(domain1)
473  call mpp_broadcast_domain(domain2)
474 
475  call mpp_redistribute(domain1,field_in,domain2,field1)
476 
477  if(any(pelist2 == pe)) then
478  do i =is,ie
479  do j =js,je
480  if(field1(i,j) .ne. field2(i,j)) then
481  print*, trim(mesg)//": ", i, j, field1(i,j), field2(i,j), field1(i,j) - field2(i,j)
482 ! write(stdout(),'(a,2i,2f)') trim(mesg), i, j, field_check(i,j), field_out(i,j)
483  check_success = .FALSE.
484  if(error_exit) call mpp_error(FATAL,"mpp_check_field: can not reproduce at this point")
485  endif
486  enddo
487  enddo
488  if(check_success) &
489  print*, trim(mesg)//": ", 'comparison between ', size(pelist1(:)), ' pes and ', &
490  size(pelist2(:)), ' pe on', pe, ' pes is ok'
491  endif
492 
493  if(any(pelist2 == pe)) deallocate(field1, field2)
494 
495  call mpp_sync()
496 
497  return
498 
499  end subroutine mpp_check_field_2d_type2
500 
501 
502 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
503 ! !
504 ! MPP_BROADCAST_DOMAIN !
505 ! !
506 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
507 
508  subroutine mpp_broadcast_domain_1( domain )
509 !broadcast domain (useful only outside the context of its own pelist)
510  type(domain2D), intent(inout) :: domain
511  integer, allocatable :: pes(:)
512  logical :: native !true if I'm on the pelist of this domain
513  integer :: listsize, listpos
514  integer :: n
515  integer, dimension(11) :: msg, info !pe and compute domain of each item in list
516  integer :: errunit
517 
518  errunit = stderr()
519  if( .NOT.module_is_initialized ) &
520  call mpp_error( FATAL, 'MPP_BROADCAST_DOMAIN_1: You must first call mpp_domains_init.' )
521 
522 !get the current pelist
523  allocate( pes(0:mpp_npes()-1) )
524  call mpp_get_current_pelist(pes)
525 
526 !am I part of this domain?
527  native = ASSOCIATED(domain%list)
528 
529 !set local list size
530  if( native )then
531  listsize = size(domain%list(:))
532  else
533  listsize = 0
534  end if
535  call mpp_max(listsize)
536 
537  if( .NOT.native )then
538 !initialize domain%list and set null values in message
539  allocate( domain%list(0:listsize-1) )
540  domain%pe = NULL_PE
541  domain%pos = -1
542  allocate(domain%x(1), domain%y(1), domain%tile_id(1))
543  do n = 0, listsize-1
544  allocate(domain%list(n)%x(1), domain%list(n)%y(1), domain%list(n)%tile_id(1) )
545  end do
546  domain%x%compute%begin = 1
547  domain%x%compute%end = -1
548  domain%y%compute%begin = 1
549  domain%y%compute%end = -1
550  domain%x%global %begin = -1
551  domain%x%global %end = -1
552  domain%y%global %begin = -1
553  domain%y%global %end = -1
554  domain%tile_id = -1
555  domain%whalo = -1
556  domain%ehalo = -1
557  domain%shalo = -1
558  domain%nhalo = -1
559  domain%symmetry = .false.
560  end if
561 !initialize values in info
562  info(1) = domain%pe
563  call mpp_get_compute_domain( domain, info(2), info(3), info(4), info(5) )
564  info(6) = domain%tile_id(1)
565  info(7) = domain%whalo
566  info(8) = domain%ehalo
567  info(9) = domain%shalo
568  info(10)= domain%nhalo
569  if(domain%symmetry) then
570  info(11) = 1
571  else
572  info(11) = 0
573  endif
574 !broadcast your info across current pelist and unpack if needed
575  listpos = 0
576  do n = 0,mpp_npes()-1
577  msg = info
578  if( mpp_pe().EQ.pes(n) .AND. debug )write( errunit,* )'PE ', mpp_pe(), 'broadcasting msg ', msg
579  call mpp_broadcast( msg, 11, pes(n) )
580 !no need to unpack message if native
581 !no need to unpack message from non-native PE
582  if( .NOT.native .AND. msg(1).NE.NULL_PE )then
583  domain%list(listpos)%pe = msg(1)
584  domain%list(listpos)%x%compute%begin = msg(2)
585  domain%list(listpos)%x%compute%end = msg(3)
586  domain%list(listpos)%y%compute%begin = msg(4)
587  domain%list(listpos)%y%compute%end = msg(5)
588  domain%list(listpos)%tile_id(1) = msg(6)
589  if(domain%x(1)%global%begin < 0) then
590  domain%x(1)%global%begin = msg(2)
591  domain%x(1)%global%end = msg(3)
592  domain%y(1)%global%begin = msg(4)
593  domain%y(1)%global%end = msg(5)
594  domain%whalo = msg(7)
595  domain%ehalo = msg(8)
596  domain%shalo = msg(9)
597  domain%nhalo = msg(10)
598  if(msg(11) == 1) then
599  domain%symmetry = .true.
600  else
601  domain%symmetry = .false.
602  endif
603  else
604  domain%x(1)%global%begin = min(domain%x(1)%global%begin, msg(2))
605  domain%x(1)%global%end = max(domain%x(1)%global%end, msg(3))
606  domain%y(1)%global%begin = min(domain%y(1)%global%begin, msg(4))
607  domain%y(1)%global%end = max(domain%y(1)%global%end, msg(5))
608  endif
609  listpos = listpos + 1
610  if( debug )write( errunit,* )'PE ', mpp_pe(), 'received domain from PE ', msg(1), 'is,ie,js,je=', msg(2:5)
611  end if
612  end do
613 
614  end subroutine mpp_broadcast_domain_1
615 
616 
617 !##############################################################################
618  subroutine mpp_broadcast_domain_2( domain_in, domain_out )
619 !broadcast domain (useful only outside the context of its own pelist)
620  type(domain2D), intent(in) :: domain_in
621  type(domain2D), intent(inout) :: domain_out
622  integer, allocatable :: pes(:)
623  logical :: native !true if I'm on the pelist of this domain
624  integer :: listsize, listpos
625  integer :: n
626  integer, dimension(12) :: msg, info !pe and compute domain of each item in list
627  integer :: errunit, npes_in, npes_out, pstart, pend
628 
629  errunit = stderr()
630  if( .NOT.module_is_initialized ) &
631  call mpp_error( FATAL, 'MPP_BROADCAST_DOMAIN_2: You must first call mpp_domains_init.' )
632 
633 !get the current pelist
634  allocate( pes(0:mpp_npes()-1) )
635  call mpp_get_current_pelist(pes)
636 
637 ! domain_in must be initialized
638  if( .not. ASSOCIATED(domain_in%list) ) then
639  call mpp_error( FATAL, 'MPP_BROADCAST_DOMAIN_2: domain_in is not initialized')
640  endif
641  if( ASSOCIATED(domain_out%list) ) then
642  call mpp_error( FATAL, 'MPP_BROADCAST_DOMAIN_2: domain_out is already initialized')
643  endif
644 
645  npes_in = size(domain_in%list(:))
646  if( npes_in == mpp_npes() ) then
647  call mpp_error( FATAL, 'MPP_BROADCAST_DOMAIN_2: size(domain_in%list(:)) == mpp_npes()')
648  endif
649  npes_out = mpp_npes() - npes_in
650 
651 !initialize domain_out%list and set null values in message
652  allocate( domain_out%list(0:npes_out-1) )
653  domain_out%pe = NULL_PE
654  domain_out%pos = -1
655  allocate(domain_out%x(1), domain_out%y(1), domain_out%tile_id(1))
656  do n = 0, npes_out-1
657  allocate(domain_out%list(n)%x(1), domain_out%list(n)%y(1), domain_out%list(n)%tile_id(1) )
658  end do
659  domain_out%x%compute%begin = 1
660  domain_out%x%compute%end = -1
661  domain_out%y%compute%begin = 1
662  domain_out%y%compute%end = -1
663  domain_out%x%global %begin = -1
664  domain_out%x%global %end = -1
665  domain_out%y%global %begin = -1
666  domain_out%y%global %end = -1
667  domain_out%tile_id = -1
668  domain_out%whalo = -1
669  domain_out%ehalo = -1
670  domain_out%shalo = -1
671  domain_out%nhalo = -1
672  domain_out%symmetry = .false.
673 !initialize values in info
674  info(1) = domain_in%pe
675  call mpp_get_compute_domain( domain_in, info(2), info(3), info(4), info(5) )
676  info(6) = domain_in%tile_id(1)
677  info(7) = domain_in%whalo
678  info(8) = domain_in%ehalo
679  info(9) = domain_in%shalo
680  info(10)= domain_in%nhalo
681  if(domain_in%symmetry) then
682  info(11) = 1
683  else
684  info(11) = 0
685  endif
686  info(12) = domain_in%ntiles
687 
688 !broadcast your info across current pelist and unpack if needed
689  if( domain_in%list(0)%pe == mpp_root_pe() ) then
690  pstart = npes_in
691  pend = mpp_npes()-1
692  else
693  pstart = 0
694  pend = npes_out-1
695  endif
696  do n = 0,mpp_npes()-1
697  msg = info
698  if( mpp_pe().EQ.pes(n) .AND. debug )write( errunit,* )'PE ', mpp_pe(), 'broadcasting msg ', msg
699  call mpp_broadcast( msg, 12, pes(n) )
700  !--- pack if from other domain
701  if( n .GE. pstart .AND. n .LE. pend )then
702  listpos = n - pstart
703  domain_out%list(listpos)%pe = msg(1)
704  domain_out%list(listpos)%x%compute%begin = msg(2)
705  domain_out%list(listpos)%x%compute%end = msg(3)
706  domain_out%list(listpos)%y%compute%begin = msg(4)
707  domain_out%list(listpos)%y%compute%end = msg(5)
708  domain_out%list(listpos)%tile_id(1) = msg(6)
709  if(domain_out%x(1)%global%begin < 0) then
710  domain_out%x(1)%global%begin = msg(2)
711  domain_out%x(1)%global%end = msg(3)
712  domain_out%y(1)%global%begin = msg(4)
713  domain_out%y(1)%global%end = msg(5)
714  domain_out%whalo = msg(7)
715  domain_out%ehalo = msg(8)
716  domain_out%shalo = msg(9)
717  domain_out%nhalo = msg(10)
718  if(msg(11) == 1) then
719  domain_out%symmetry = .true.
720  else
721  domain_out%symmetry = .false.
722  endif
723  domain_out%ntiles = msg(12)
724  else
725  domain_out%x(1)%global%begin = min(domain_out%x(1)%global%begin, msg(2))
726  domain_out%x(1)%global%end = max(domain_out%x(1)%global%end, msg(3))
727  domain_out%y(1)%global%begin = min(domain_out%y(1)%global%begin, msg(4))
728  domain_out%y(1)%global%end = max(domain_out%y(1)%global%end, msg(5))
729  endif
730  if( debug )write( errunit,* )'PE ', mpp_pe(), 'received domain from PE ', msg(1), 'is,ie,js,je=', msg(2:5)
731  end if
732  end do
733 
734  end subroutine mpp_broadcast_domain_2
735 
736 
737 
738 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
739 ! !
740 ! MPP_UPDATE_DOMAINS: fill halos for 2D decomposition !
741 ! !
742 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
743 
744 #undef VECTOR_FIELD_
745 #define VECTOR_FIELD_
746 #undef MPP_TYPE_
747 #define MPP_TYPE_ real(DOUBLE_KIND)
748 #undef MPP_UPDATE_DOMAINS_2D_
749 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_r8_2D
750 #undef MPP_UPDATE_DOMAINS_3D_
751 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_r8_3D
752 #undef MPP_UPDATE_DOMAINS_4D_
753 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_r8_4D
754 #undef MPP_UPDATE_DOMAINS_5D_
755 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_r8_5D
756 #ifdef VECTOR_FIELD_
757 #undef MPP_UPDATE_DOMAINS_2D_V_
758 #define MPP_UPDATE_DOMAINS_2D_V_ mpp_update_domain2D_r8_2Dv
759 #undef MPP_UPDATE_DOMAINS_3D_V_
760 #define MPP_UPDATE_DOMAINS_3D_V_ mpp_update_domain2D_r8_3Dv
761 #undef MPP_UPDATE_DOMAINS_4D_V_
762 #define MPP_UPDATE_DOMAINS_4D_V_ mpp_update_domain2D_r8_4Dv
763 #undef MPP_UPDATE_DOMAINS_5D_V_
764 #define MPP_UPDATE_DOMAINS_5D_V_ mpp_update_domain2D_r8_5Dv
765 #endif
766 #undef MPP_REDISTRIBUTE_2D_
767 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_r8_2D
768 #undef MPP_REDISTRIBUTE_3D_
769 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_r8_3D
770 #undef MPP_REDISTRIBUTE_4D_
771 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_r8_4D
772 #undef MPP_REDISTRIBUTE_5D_
773 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_r8_5D
774 #include <mpp_update_domains2D.h>
775 #undef VECTOR_FIELD_
776 
777 #ifdef OVERLOAD_C8
778 #undef MPP_TYPE_
779 #define MPP_TYPE_ complex(DOUBLE_KIND)
780 #undef MPP_UPDATE_DOMAINS_2D_
781 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_c8_2D
782 #undef MPP_UPDATE_DOMAINS_3D_
783 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_c8_3D
784 #undef MPP_UPDATE_DOMAINS_4D_
785 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_c8_4D
786 #undef MPP_UPDATE_DOMAINS_5D_
787 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_c8_5D
788 #undef MPP_REDISTRIBUTE_2D_
789 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_c8_2D
790 #undef MPP_REDISTRIBUTE_3D_
791 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_c8_3D
792 #undef MPP_REDISTRIBUTE_4D_
793 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_c8_4D
794 #undef MPP_REDISTRIBUTE_5D_
795 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_c8_5D
796 #include <mpp_update_domains2D.h>
797 #endif
798 
799 #ifndef no_8byte_integers
800 #undef MPP_TYPE_
801 #define MPP_TYPE_ integer(LONG_KIND)
802 #undef MPP_UPDATE_DOMAINS_2D_
803 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_i8_2D
804 #undef MPP_UPDATE_DOMAINS_3D_
805 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_i8_3D
806 #undef MPP_UPDATE_DOMAINS_4D_
807 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_i8_4D
808 #undef MPP_UPDATE_DOMAINS_5D_
809 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_i8_5D
810 #undef MPP_REDISTRIBUTE_2D_
811 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_i8_2D
812 #undef MPP_REDISTRIBUTE_3D_
813 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_i8_3D
814 #undef MPP_REDISTRIBUTE_4D_
815 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_i8_4D
816 #undef MPP_REDISTRIBUTE_5D_
817 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_i8_5D
818 #include <mpp_update_domains2D.h>
819 #endif
820 
821 #ifdef OVERLOAD_R4
822 #undef VECTOR_FIELD_
823 #define VECTOR_FIELD_
824 #undef MPP_TYPE_
825 #define MPP_TYPE_ real(FLOAT_KIND)
826 #undef MPP_UPDATE_DOMAINS_2D_
827 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_r4_2D
828 #undef MPP_UPDATE_DOMAINS_3D_
829 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_r4_3D
830 #undef MPP_UPDATE_DOMAINS_4D_
831 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_r4_4D
832 #undef MPP_UPDATE_DOMAINS_5D_
833 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_r4_5D
834 #ifdef VECTOR_FIELD_
835 #undef MPP_UPDATE_DOMAINS_2D_V_
836 #define MPP_UPDATE_DOMAINS_2D_V_ mpp_update_domain2D_r4_2Dv
837 #undef MPP_UPDATE_DOMAINS_3D_V_
838 #define MPP_UPDATE_DOMAINS_3D_V_ mpp_update_domain2D_r4_3Dv
839 #undef MPP_UPDATE_DOMAINS_4D_V_
840 #define MPP_UPDATE_DOMAINS_4D_V_ mpp_update_domain2D_r4_4Dv
841 #undef MPP_UPDATE_DOMAINS_5D_V_
842 #define MPP_UPDATE_DOMAINS_5D_V_ mpp_update_domain2D_r4_5Dv
843 #endif
844 #undef MPP_REDISTRIBUTE_2D_
845 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_r4_2D
846 #undef MPP_REDISTRIBUTE_3D_
847 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_r4_3D
848 #undef MPP_REDISTRIBUTE_4D_
849 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_r4_4D
850 #undef MPP_REDISTRIBUTE_5D_
851 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_r4_5D
852 #include <mpp_update_domains2D.h>
853 #undef VECTOR_FIELD_
854 #endif
855 
856 #ifdef OVERLOAD_C4
857 #undef MPP_TYPE_
858 #define MPP_TYPE_ complex(FLOAT_KIND)
859 #undef MPP_UPDATE_DOMAINS_2D_
860 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_c4_2D
861 #undef MPP_UPDATE_DOMAINS_3D_
862 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_c4_3D
863 #undef MPP_UPDATE_DOMAINS_4D_
864 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_c4_4D
865 #undef MPP_UPDATE_DOMAINS_5D_
866 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_c4_5D
867 #undef MPP_REDISTRIBUTE_2D_
868 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_c4_2D
869 #undef MPP_REDISTRIBUTE_3D_
870 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_c4_3D
871 #undef MPP_REDISTRIBUTE_4D_
872 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_c4_4D
873 #undef MPP_REDISTRIBUTE_5D_
874 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_c4_5D
875 #include <mpp_update_domains2D.h>
876 #endif
877 
878 #undef MPP_TYPE_
879 #define MPP_TYPE_ integer(INT_KIND)
880 #undef MPP_UPDATE_DOMAINS_2D_
881 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_i4_2D
882 #undef MPP_UPDATE_DOMAINS_3D_
883 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_i4_3D
884 #undef MPP_UPDATE_DOMAINS_4D_
885 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_i4_4D
886 #undef MPP_UPDATE_DOMAINS_5D_
887 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_i4_5D
888 #undef MPP_REDISTRIBUTE_2D_
889 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_i4_2D
890 #undef MPP_REDISTRIBUTE_3D_
891 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_i4_3D
892 #undef MPP_REDISTRIBUTE_4D_
893 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_i4_4D
894 #undef MPP_REDISTRIBUTE_5D_
895 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_i4_5D
896 #include <mpp_update_domains2D.h>
897 
898 
899 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
900 ! !
901 ! MPP_START_UPDATE_DOMAINS and MPP_COMPLETE_UPDATE_DOMAINS: !
902 ! fill halos for 2D decomposition --- non-blocking !
903 ! !
904 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
905 
906 #undef VECTOR_FIELD_
907 #define VECTOR_FIELD_
908 #undef MPP_TYPE_
909 #define MPP_TYPE_ real(DOUBLE_KIND)
910 #undef MPP_START_UPDATE_DOMAINS_2D_
911 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_r8_2D
912 #undef MPP_START_UPDATE_DOMAINS_3D_
913 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_r8_3D
914 #undef MPP_START_UPDATE_DOMAINS_4D_
915 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_r8_4D
916 #undef MPP_START_UPDATE_DOMAINS_5D_
917 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_r8_5D
918 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
919 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_r8_2D
920 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
921 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_r8_3D
922 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
923 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_r8_4D
924 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
925 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_r8_5D
926 #ifdef VECTOR_FIELD_
927 #undef MPP_START_UPDATE_DOMAINS_2D_V_
928 #define MPP_START_UPDATE_DOMAINS_2D_V_ mpp_start_update_domain2D_r8_2Dv
929 #undef MPP_START_UPDATE_DOMAINS_3D_V_
930 #define MPP_START_UPDATE_DOMAINS_3D_V_ mpp_start_update_domain2D_r8_3Dv
931 #undef MPP_START_UPDATE_DOMAINS_4D_V_
932 #define MPP_START_UPDATE_DOMAINS_4D_V_ mpp_start_update_domain2D_r8_4Dv
933 #undef MPP_START_UPDATE_DOMAINS_5D_V_
934 #define MPP_START_UPDATE_DOMAINS_5D_V_ mpp_start_update_domain2D_r8_5Dv
935 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_V_
936 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_V_ mpp_complete_update_domain2D_r8_2Dv
937 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_V_
938 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_V_ mpp_complete_update_domain2D_r8_3Dv
939 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_V_
940 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_V_ mpp_complete_update_domain2D_r8_4Dv
941 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_V_
942 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_V_ mpp_complete_update_domain2D_r8_5Dv
943 #endif
944 #include <mpp_update_domains2D_nonblock.h>
945 
946 #ifdef OVERLOAD_C8
947 #undef VECTOR_FIELD_
948 #undef MPP_TYPE_
949 #define MPP_TYPE_ complex(DOUBLE_KIND)
950 #undef MPP_START_UPDATE_DOMAINS_2D_
951 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_c8_2D
952 #undef MPP_START_UPDATE_DOMAINS_3D_
953 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_c8_3D
954 #undef MPP_START_UPDATE_DOMAINS_4D_
955 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_c8_4D
956 #undef MPP_START_UPDATE_DOMAINS_5D_
957 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_c8_5D
958 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
959 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_c8_2D
960 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
961 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_c8_3D
962 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
963 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_c8_4D
964 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
965 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_c8_5D
966 #include <mpp_update_domains2D_nonblock.h>
967 #endif
968 
969 #ifndef no_8byte_integers
970 #undef VECTOR_FIELD_
971 #undef MPP_TYPE_
972 #define MPP_TYPE_ integer(LONG_KIND)
973 #undef MPP_START_UPDATE_DOMAINS_2D_
974 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_i8_2D
975 #undef MPP_START_UPDATE_DOMAINS_3D_
976 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_i8_3D
977 #undef MPP_START_UPDATE_DOMAINS_4D_
978 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_i8_4D
979 #undef MPP_START_UPDATE_DOMAINS_5D_
980 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_i8_5D
981 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
982 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_i8_2D
983 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
984 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_i8_3D
985 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
986 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_i8_4D
987 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
988 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_i8_5D
989 #include <mpp_update_domains2D_nonblock.h>
990 #endif
991 
992 #ifdef OVERLOAD_R4
993 #undef VECTOR_FIELD_
994 #define VECTOR_FIELD_
995 #undef MPP_TYPE_
996 #define MPP_TYPE_ real(FLOAT_KIND)
997 #undef MPP_START_UPDATE_DOMAINS_2D_
998 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_r4_2D
999 #undef MPP_START_UPDATE_DOMAINS_3D_
1000 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_r4_3D
1001 #undef MPP_START_UPDATE_DOMAINS_4D_
1002 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_r4_4D
1003 #undef MPP_START_UPDATE_DOMAINS_5D_
1004 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_r4_5D
1005 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
1006 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_r4_2D
1007 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
1008 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_r4_3D
1009 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
1010 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_r4_4D
1011 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
1012 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_r4_5D
1013 #ifdef VECTOR_FIELD_
1014 #undef MPP_START_UPDATE_DOMAINS_2D_V_
1015 #define MPP_START_UPDATE_DOMAINS_2D_V_ mpp_start_update_domain2D_r4_2Dv
1016 #undef MPP_START_UPDATE_DOMAINS_3D_V_
1017 #define MPP_START_UPDATE_DOMAINS_3D_V_ mpp_start_update_domain2D_r4_3Dv
1018 #undef MPP_START_UPDATE_DOMAINS_4D_V_
1019 #define MPP_START_UPDATE_DOMAINS_4D_V_ mpp_start_update_domain2D_r4_4Dv
1020 #undef MPP_START_UPDATE_DOMAINS_5D_V_
1021 #define MPP_START_UPDATE_DOMAINS_5D_V_ mpp_start_update_domain2D_r4_5Dv
1022 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_V_
1023 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_V_ mpp_complete_update_domain2D_r4_2Dv
1024 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_V_
1025 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_V_ mpp_complete_update_domain2D_r4_3Dv
1026 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_V_
1027 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_V_ mpp_complete_update_domain2D_r4_4Dv
1028 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_V_
1029 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_V_ mpp_complete_update_domain2D_r4_5Dv
1030 #endif
1031 #include <mpp_update_domains2D_nonblock.h>
1032 #endif
1033 
1034 #ifdef OVERLOAD_C4
1035 #undef VECTOR_FIELD_
1036 #undef MPP_TYPE_
1037 #define MPP_TYPE_ complex(FLOAT_KIND)
1038 #undef MPP_START_UPDATE_DOMAINS_2D_
1039 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_c4_2D
1040 #undef MPP_START_UPDATE_DOMAINS_3D_
1041 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_c4_3D
1042 #undef MPP_START_UPDATE_DOMAINS_4D_
1043 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_c4_4D
1044 #undef MPP_START_UPDATE_DOMAINS_5D_
1045 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_c4_5D
1046 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
1047 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_c4_2D
1048 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
1049 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_c4_3D
1050 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
1051 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_c4_4D
1052 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
1053 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_c4_5D
1054 #include <mpp_update_domains2D_nonblock.h>
1055 #endif
1056 
1057 #undef VECTOR_FIELD_
1058 #undef MPP_TYPE_
1059 #define MPP_TYPE_ integer(INT_KIND)
1060 #undef MPP_START_UPDATE_DOMAINS_2D_
1061 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_i4_2D
1062 #undef MPP_START_UPDATE_DOMAINS_3D_
1063 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_i4_3D
1064 #undef MPP_START_UPDATE_DOMAINS_4D_
1065 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_i4_4D
1066 #undef MPP_START_UPDATE_DOMAINS_5D_
1067 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_i4_5D
1068 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
1069 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_i4_2D
1070 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
1071 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_i4_3D
1072 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
1073 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_i4_4D
1074 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
1075 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_i4_5D
1076 #include <mpp_update_domains2D_nonblock.h>
1077 
1078 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1079 ! !
1080 ! mpp_start_do_update and mpp_complete_do_update !
1081 ! private routine. To be called in mpp_start_update_domains !
1082 ! and mpp_complete_update_domains !
1083 ! !
1084 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1085 #undef MPP_TYPE_
1086 #define MPP_TYPE_ real(DOUBLE_KIND)
1087 #undef MPI_TYPE_
1088 #define MPI_TYPE_ MPI_REAL8
1089 #undef MPP_START_DO_UPDATE_3D_
1090 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_r8_3D
1091 #undef MPP_COMPLETE_DO_UPDATE_3D_
1092 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_r8_3D
1093 #undef MPP_START_DO_UPDATE_3D_V_
1094 #define MPP_START_DO_UPDATE_3D_V_ mpp_start_do_update_r8_3Dv
1095 #undef MPP_COMPLETE_DO_UPDATE_3D_V_
1096 #define MPP_COMPLETE_DO_UPDATE_3D_V_ mpp_complete_do_update_r8_3Dv
1097 #include <mpp_do_update_nonblock.h>
1098 #include <mpp_do_updateV_nonblock.h>
1099 
1100 #ifdef OVERLOAD_C8
1101 #undef MPP_TYPE_
1102 #define MPP_TYPE_ complex(DOUBLE_KIND)
1103 #undef MPI_TYPE_
1104 #define MPI_TYPE_ MPI_DOUBLE_COMPLEX
1105 #undef MPP_START_DO_UPDATE_3D_
1106 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_c8_3D
1107 #undef MPP_COMPLETE_DO_UPDATE_3D_
1108 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_c8_3D
1109 #include <mpp_do_update_nonblock.h>
1110 #endif
1111 
1112 #ifndef no_8byte_integers
1113 #undef MPP_TYPE_
1114 #define MPP_TYPE_ integer(LONG_KIND)
1115 #undef MPI_TYPE_
1116 #define MPI_TYPE_ MPI_INTEGER8
1117 #undef MPP_START_DO_UPDATE_3D_
1118 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_i8_3D
1119 #undef MPP_COMPLETE_DO_UPDATE_3D_
1120 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_i8_3D
1121 #include <mpp_do_update_nonblock.h>
1122 #endif
1123 
1124 #ifdef OVERLOAD_R4
1125 #undef MPP_TYPE_
1126 #define MPP_TYPE_ real(FLOAT_KIND)
1127 #undef MPI_TYPE_
1128 #define MPI_TYPE_ MPI_REAL4
1129 #undef MPP_START_DO_UPDATE_3D_
1130 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_r4_3D
1131 #undef MPP_COMPLETE_DO_UPDATE_3D_
1132 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_r4_3D
1133 #undef MPP_START_DO_UPDATE_3D_V_
1134 #define MPP_START_DO_UPDATE_3D_V_ mpp_start_do_update_r4_3Dv
1135 #undef MPP_COMPLETE_DO_UPDATE_3D_V_
1136 #define MPP_COMPLETE_DO_UPDATE_3D_V_ mpp_complete_do_update_r4_3Dv
1137 #include <mpp_do_update_nonblock.h>
1138 #include <mpp_do_updateV_nonblock.h>
1139 #endif
1140 
1141 #ifdef OVERLOAD_C4
1142 #undef MPP_TYPE_
1143 #define MPP_TYPE_ complex(FLOAT_KIND)
1144 #undef MPI_TYPE_
1145 #define MPI_TYPE_ MPI_COMPLEX
1146 #undef MPP_START_DO_UPDATE_3D_
1147 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_c4_3D
1148 #undef MPP_COMPLETE_DO_UPDATE_3D_
1149 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_c4_3D
1150 #include <mpp_do_update_nonblock.h>
1151 #endif
1152 
1153 #undef MPP_TYPE_
1154 #define MPP_TYPE_ integer(INT_KIND)
1155 #undef MPI_TYPE_
1156 #define MPI_TYPE_ MPI_INTEGER4
1157 #undef MPP_START_DO_UPDATE_3D_
1158 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_i4_3D
1159 #undef MPP_COMPLETE_DO_UPDATE_3D_
1160 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_i4_3D
1161 #include <mpp_do_update_nonblock.h>
1162 
1163 !*******************************************************
1164 #undef VECTOR_FIELD_
1165 #define VECTOR_FIELD_
1166 #undef MPP_TYPE_
1167 #define MPP_TYPE_ real(DOUBLE_KIND)
1168 #undef MPP_DO_UPDATE_3D_
1169 #define MPP_DO_UPDATE_3D_ mpp_do_update_r8_3d
1170 #ifdef VECTOR_FIELD_
1171 #undef MPP_DO_UPDATE_3D_V_
1172 #define MPP_DO_UPDATE_3D_V_ mpp_do_update_r8_3dv
1173 #endif
1174 #include <mpp_do_update.h>
1175 #include <mpp_do_updateV.h>
1176 
1177 #ifdef OVERLOAD_C8
1178 #undef VECTOR_FIELD_
1179 #undef MPP_TYPE_
1180 #define MPP_TYPE_ complex(DOUBLE_KIND)
1181 #undef MPP_DO_UPDATE_3D_
1182 #define MPP_DO_UPDATE_3D_ mpp_do_update_c8_3d
1183 #include <mpp_do_update.h>
1184 #define VECTOR_FIELD_
1185 #endif
1186 
1187 #ifndef no_8byte_integers
1188 #undef MPP_TYPE_
1189 #define MPP_TYPE_ integer(LONG_KIND)
1190 #undef MPP_DO_UPDATE_3D_
1191 #define MPP_DO_UPDATE_3D_ mpp_do_update_i8_3d
1192 #include <mpp_do_update.h>
1193 #endif
1194 
1195 #ifdef OVERLOAD_R4
1196 #undef VECTOR_FIELD_
1197 #define VECTOR_FIELD_
1198 #undef MPP_TYPE_
1199 #define MPP_TYPE_ real(FLOAT_KIND)
1200 #undef MPP_DO_UPDATE_3D_
1201 #define MPP_DO_UPDATE_3D_ mpp_do_update_r4_3d
1202 #ifdef VECTOR_FIELD_
1203 #undef MPP_DO_UPDATE_3D_V_
1204 #define MPP_DO_UPDATE_3D_V_ mpp_do_update_r4_3dv
1205 #endif
1206 #include <mpp_do_update.h>
1207 #include <mpp_do_updateV.h>
1208 #endif
1209 
1210 #ifdef OVERLOAD_C4
1211 #undef VECTOR_FIELD_
1212 #undef MPP_TYPE_
1213 #define MPP_TYPE_ complex(FLOAT_KIND)
1214 #undef MPP_DO_UPDATE_3D_
1215 #define MPP_DO_UPDATE_3D_ mpp_do_update_c4_3d
1216 #include <mpp_do_update.h>
1217 #define VECTOR_FIELD_
1218 #endif
1219 
1220 #undef MPP_TYPE_
1221 #define MPP_TYPE_ integer(INT_KIND)
1222 #undef MPP_DO_UPDATE_3D_
1223 #define MPP_DO_UPDATE_3D_ mpp_do_update_i4_3d
1224 #include <mpp_do_update.h>
1225 
1226 
1227 #undef MPP_TYPE_
1228 #define MPP_TYPE_ real(DOUBLE_KIND)
1229 #undef MPP_DO_CHECK_3D_
1230 #define MPP_DO_CHECK_3D_ mpp_do_check_r8_3d
1231 #ifdef VECTOR_FIELD_
1232 #undef MPP_DO_CHECK_3D_V_
1233 #define MPP_DO_CHECK_3D_V_ mpp_do_check_r8_3dv
1234 #endif
1235 #include <mpp_do_check.h>
1236 #include <mpp_do_checkV.h>
1237 
1238 #ifdef OVERLOAD_C8
1239 #undef VECTOR_FIELD_
1240 #undef MPP_TYPE_
1241 #define MPP_TYPE_ complex(DOUBLE_KIND)
1242 #undef MPP_DO_CHECK_3D_
1243 #define MPP_DO_CHECK_3D_ mpp_do_check_c8_3d
1244 #include <mpp_do_check.h>
1245 #define VECTOR_FIELD_
1246 #endif
1247 
1248 #ifndef no_8byte_integers
1249 #undef MPP_TYPE_
1250 #define MPP_TYPE_ integer(LONG_KIND)
1251 #undef MPP_DO_CHECK_3D_
1252 #define MPP_DO_CHECK_3D_ mpp_do_check_i8_3d
1253 #include <mpp_do_check.h>
1254 #endif
1255 
1256 #ifdef OVERLOAD_R4
1257 #undef VECTOR_FIELD_
1258 #define VECTOR_FIELD_
1259 #undef MPP_TYPE_
1260 #define MPP_TYPE_ real(FLOAT_KIND)
1261 #undef MPP_DO_CHECK_3D_
1262 #define MPP_DO_CHECK_3D_ mpp_do_check_r4_3d
1263 #ifdef VECTOR_FIELD_
1264 #undef MPP_DO_CHECK_3D_V_
1265 #define MPP_DO_CHECK_3D_V_ mpp_do_check_r4_3dv
1266 #endif
1267 #include <mpp_do_check.h>
1268 #include <mpp_do_checkV.h>
1269 #endif
1270 
1271 #ifdef OVERLOAD_C4
1272 #undef VECTOR_FIELD_
1273 #undef MPP_TYPE_
1274 #define MPP_TYPE_ complex(FLOAT_KIND)
1275 #undef MPP_DO_CHECK_3D_
1276 #define MPP_DO_CHECK_3D_ mpp_do_check_c4_3d
1277 #include <mpp_do_check.h>
1278 #endif
1279 
1280 #undef MPP_TYPE_
1281 #define MPP_TYPE_ integer(INT_KIND)
1282 #undef MPP_DO_CHECK_3D_
1283 #define MPP_DO_CHECK_3D_ mpp_do_check_i4_3d
1284 #include <mpp_do_check.h>
1285 
1286 #undef VECTOR_FIELD_
1287 #define VECTOR_FIELD_
1288 #undef MPP_TYPE_
1289 #define MPP_TYPE_ real(DOUBLE_KIND)
1290 #undef MPP_UPDATE_NEST_FINE_2D_
1291 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_r8_2D
1292 #undef MPP_UPDATE_NEST_FINE_3D_
1293 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_r8_3D
1294 #undef MPP_UPDATE_NEST_FINE_4D_
1295 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_r8_4D
1296 #undef MPP_UPDATE_NEST_COARSE_2D_
1297 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_r8_2D
1298 #undef MPP_UPDATE_NEST_COARSE_3D_
1299 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_r8_3D
1300 #undef MPP_UPDATE_NEST_COARSE_4D_
1301 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_r8_4D
1302 #include <mpp_update_nest_domains.h>
1303 
1304 #ifdef OVERLOAD_C8
1305 #undef VECTOR_FIELD_
1306 #define VECTOR_FIELD_
1307 #undef MPP_TYPE_
1308 #define MPP_TYPE_ complex(DOUBLE_KIND)
1309 #undef MPP_UPDATE_NEST_FINE_2D_
1310 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_c8_2D
1311 #undef MPP_UPDATE_NEST_FINE_3D_
1312 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_c8_3D
1313 #undef MPP_UPDATE_NEST_FINE_4D_
1314 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_c8_4D
1315 #undef MPP_UPDATE_NEST_COARSE_2D_
1316 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_c8_2D
1317 #undef MPP_UPDATE_NEST_COARSE_3D_
1318 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_c8_3D
1319 #undef MPP_UPDATE_NEST_COARSE_4D_
1320 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_c8_4D
1321 #include <mpp_update_nest_domains.h>
1322 #endif
1323 
1324 #ifndef no_8byte_integers
1325 #undef VECTOR_FIELD_
1326 #define VECTOR_FIELD_
1327 #undef MPP_TYPE_
1328 #define MPP_TYPE_ integer(LONG_KIND)
1329 #undef MPP_UPDATE_NEST_FINE_2D_
1330 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_i8_2D
1331 #undef MPP_UPDATE_NEST_FINE_3D_
1332 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_i8_3D
1333 #undef MPP_UPDATE_NEST_FINE_4D_
1334 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_i8_4D
1335 #undef MPP_UPDATE_NEST_COARSE_2D_
1336 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_i8_2D
1337 #undef MPP_UPDATE_NEST_COARSE_3D_
1338 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_i8_3D
1339 #undef MPP_UPDATE_NEST_COARSE_4D_
1340 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_i8_4D
1341 #include <mpp_update_nest_domains.h>
1342 #endif
1343 
1344 #ifdef OVERLOAD_R4
1345 #undef VECTOR_FIELD_
1346 #define VECTOR_FIELD_
1347 #undef MPP_TYPE_
1348 #define MPP_TYPE_ real(FLOAT_KIND)
1349 #undef MPP_UPDATE_NEST_FINE_2D_
1350 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_r4_2D
1351 #undef MPP_UPDATE_NEST_FINE_3D_
1352 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_r4_3D
1353 #undef MPP_UPDATE_NEST_FINE_4D_
1354 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_r4_4D
1355 #undef MPP_UPDATE_NEST_COARSE_2D_
1356 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_r4_2D
1357 #undef MPP_UPDATE_NEST_COARSE_3D_
1358 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_r4_3D
1359 #undef MPP_UPDATE_NEST_COARSE_4D_
1360 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_r4_4D
1361 #include <mpp_update_nest_domains.h>
1362 #endif
1363 
1364 #ifdef OVERLOAD_C4
1365 #undef VECTOR_FIELD_
1366 #define VECTOR_FIELD_
1367 #undef MPP_TYPE_
1368 #define MPP_TYPE_ complex(FLOAT_KIND)
1369 #undef MPP_UPDATE_NEST_FINE_2D_
1370 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_c4_2D
1371 #undef MPP_UPDATE_NEST_FINE_3D_
1372 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_c4_3D
1373 #undef MPP_UPDATE_NEST_FINE_4D_
1374 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_c4_4D
1375 #undef MPP_UPDATE_NEST_COARSE_2D_
1376 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_c4_2D
1377 #undef MPP_UPDATE_NEST_COARSE_3D_
1378 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_c4_3D
1379 #undef MPP_UPDATE_NEST_COARSE_4D_
1380 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_c4_4D
1381 #include <mpp_update_nest_domains.h>
1382 #endif
1383 
1384 #undef VECTOR_FIELD_
1385 #define VECTOR_FIELD_
1386 #undef MPP_TYPE_
1387 #define MPP_TYPE_ integer(INT_KIND)
1388 #undef MPP_UPDATE_NEST_FINE_2D_
1389 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_i4_2D
1390 #undef MPP_UPDATE_NEST_FINE_3D_
1391 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_i4_3D
1392 #undef MPP_UPDATE_NEST_FINE_4D_
1393 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_i4_4D
1394 #undef MPP_UPDATE_NEST_COARSE_2D_
1395 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_i4_2D
1396 #undef MPP_UPDATE_NEST_COARSE_3D_
1397 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_i4_3D
1398 #undef MPP_UPDATE_NEST_COARSE_4D_
1399 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_i4_4D
1400 #include <mpp_update_nest_domains.h>
1401 
1402 #undef VECTOR_FIELD_
1403 #define VECTOR_FIELD_
1404 #undef MPP_TYPE_
1405 #define MPP_TYPE_ real(DOUBLE_KIND)
1406 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1407 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_r8_3D
1408 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1409 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_r8_3D
1410 #include <mpp_do_update_nest.h>
1411 
1412 #ifdef OVERLOAD_C8
1413 #undef VECTOR_FIELD_
1414 #define VECTOR_FIELD_
1415 #undef MPP_TYPE_
1416 #define MPP_TYPE_ complex(DOUBLE_KIND)
1417 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1418 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_c8_3D
1419 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1420 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_c8_3D
1421 #include <mpp_do_update_nest.h>
1422 #endif
1423 
1424 #ifndef no_8byte_integers
1425 #undef VECTOR_FIELD_
1426 #define VECTOR_FIELD_
1427 #undef MPP_TYPE_
1428 #define MPP_TYPE_ integer(LONG_KIND)
1429 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1430 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_i8_3D
1431 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1432 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_i8_3D
1433 #include <mpp_do_update_nest.h>
1434 #endif
1435 
1436 #ifdef OVERLOAD_R4
1437 #undef VECTOR_FIELD_
1438 #define VECTOR_FIELD_
1439 #undef MPP_TYPE_
1440 #define MPP_TYPE_ real(FLOAT_KIND)
1441 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1442 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_r4_3D
1443 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1444 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_r4_3D
1445 #include <mpp_do_update_nest.h>
1446 #endif
1447 
1448 #ifdef OVERLOAD_C4
1449 #undef VECTOR_FIELD_
1450 #define VECTOR_FIELD_
1451 #undef MPP_TYPE_
1452 #define MPP_TYPE_ complex(FLOAT_KIND)
1453 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1454 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_c4_3D
1455 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1456 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_c4_3D
1457 #include <mpp_do_update_nest.h>
1458 #endif
1459 
1460 #undef VECTOR_FIELD_
1461 #define VECTOR_FIELD_
1462 #undef MPP_TYPE_
1463 #define MPP_TYPE_ integer(INT_KIND)
1464 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1465 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_i4_3D
1466 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1467 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_i4_3D
1468 #include <mpp_do_update_nest.h>
1469 
1470 !bnc
1471 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1472 ! !
1473 ! MPP_UPDATE_DOMAINS_AD: adjoint fill halos for 2D decomposition !
1474 ! !
1475 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1476 #undef VECTOR_FIELD_
1477 #define VECTOR_FIELD_
1478 #undef MPP_TYPE_
1479 #define MPP_TYPE_ real(DOUBLE_KIND)
1480 #undef MPP_UPDATE_DOMAINS_AD_2D_
1481 #define MPP_UPDATE_DOMAINS_AD_2D_ mpp_update_domains_ad_2D_r8_2D
1482 #undef MPP_UPDATE_DOMAINS_AD_3D_
1483 #define MPP_UPDATE_DOMAINS_AD_3D_ mpp_update_domains_ad_2D_r8_3D
1484 #undef MPP_UPDATE_DOMAINS_AD_4D_
1485 #define MPP_UPDATE_DOMAINS_AD_4D_ mpp_update_domains_ad_2D_r8_4D
1486 #undef MPP_UPDATE_DOMAINS_AD_5D_
1487 #define MPP_UPDATE_DOMAINS_AD_5D_ mpp_update_domains_ad_2D_r8_5D
1488 #ifdef VECTOR_FIELD_
1489 #undef MPP_UPDATE_DOMAINS_AD_2D_V_
1490 #define MPP_UPDATE_DOMAINS_AD_2D_V_ mpp_update_domains_ad_2D_r8_2Dv
1491 #undef MPP_UPDATE_DOMAINS_AD_3D_V_
1492 #define MPP_UPDATE_DOMAINS_AD_3D_V_ mpp_update_domains_ad_2D_r8_3Dv
1493 #undef MPP_UPDATE_DOMAINS_AD_4D_V_
1494 #define MPP_UPDATE_DOMAINS_AD_4D_V_ mpp_update_domains_ad_2D_r8_4Dv
1495 #undef MPP_UPDATE_DOMAINS_AD_5D_V_
1496 #define MPP_UPDATE_DOMAINS_AD_5D_V_ mpp_update_domains_ad_2D_r8_5Dv
1497 #endif
1498 #include <mpp_update_domains2D_ad.h>
1499 
1500 #ifdef OVERLOAD_R4
1501 #undef VECTOR_FIELD_
1502 #define VECTOR_FIELD_
1503 #undef MPP_TYPE_
1504 #define MPP_TYPE_ real(FLOAT_KIND)
1505 #undef MPP_UPDATE_DOMAINS_AD_2D_
1506 #define MPP_UPDATE_DOMAINS_AD_2D_ mpp_update_domains_ad_2D_r4_2D
1507 #undef MPP_UPDATE_DOMAINS_AD_3D_
1508 #define MPP_UPDATE_DOMAINS_AD_3D_ mpp_update_domains_ad_2D_r4_3D
1509 #undef MPP_UPDATE_DOMAINS_AD_4D_
1510 #define MPP_UPDATE_DOMAINS_AD_4D_ mpp_update_domains_ad_2D_r4_4D
1511 #undef MPP_UPDATE_DOMAINS_AD_5D_
1512 #define MPP_UPDATE_DOMAINS_AD_5D_ mpp_update_domains_ad_2D_r4_5D
1513 #ifdef VECTOR_FIELD_
1514 #undef MPP_UPDATE_DOMAINS_AD_2D_V_
1515 #define MPP_UPDATE_DOMAINS_AD_2D_V_ mpp_update_domains_ad_2D_r4_2Dv
1516 #undef MPP_UPDATE_DOMAINS_AD_3D_V_
1517 #define MPP_UPDATE_DOMAINS_AD_3D_V_ mpp_update_domains_ad_2D_r4_3Dv
1518 #undef MPP_UPDATE_DOMAINS_AD_4D_V_
1519 #define MPP_UPDATE_DOMAINS_AD_4D_V_ mpp_update_domains_ad_2D_r4_4Dv
1520 #undef MPP_UPDATE_DOMAINS_AD_5D_V_
1521 #define MPP_UPDATE_DOMAINS_AD_5D_V_ mpp_update_domains_ad_2D_r4_5Dv
1522 #endif
1523 #include <mpp_update_domains2D_ad.h>
1524 #endif
1525 
1526 
1527 !!$
1528 !!$!*******************************************************
1529 #undef VECTOR_FIELD_
1530 #define VECTOR_FIELD_
1531 #undef MPP_TYPE_
1532 #define MPP_TYPE_ real(DOUBLE_KIND)
1533 #undef MPP_DO_UPDATE_AD_3D_
1534 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_r8_3d
1535 #ifdef VECTOR_FIELD_
1536 #undef MPP_DO_UPDATE_AD_3D_V_
1537 #define MPP_DO_UPDATE_AD_3D_V_ mpp_do_update_ad_r8_3dv
1538 #endif
1539 #include <mpp_do_update_ad.h>
1540 #include <mpp_do_updateV_ad.h>
1541 
1542 #ifdef OVERLOAD_C8
1543 #undef VECTOR_FIELD_
1544 #undef MPP_TYPE_
1545 #define MPP_TYPE_ complex(DOUBLE_KIND)
1546 #undef MPP_DO_UPDATE_AD_3D_
1547 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_c8_3d
1548 #include <mpp_do_update_ad.h>
1549 #define VECTOR_FIELD_
1550 #endif
1551 
1552 #ifndef no_8byte_integers
1553 #undef MPP_TYPE_
1554 #define MPP_TYPE_ integer(LONG_KIND)
1555 #undef MPP_DO_UPDATE_AD_3D_
1556 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_i8_3d
1557 #include <mpp_do_update_ad.h>
1558 #endif
1559 
1560 #ifdef OVERLOAD_R4
1561 #undef VECTOR_FIELD_
1562 #define VECTOR_FIELD_
1563 #undef MPP_TYPE_
1564 #define MPP_TYPE_ real(FLOAT_KIND)
1565 #undef MPP_DO_UPDATE_AD_3D_
1566 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_r4_3d
1567 #ifdef VECTOR_FIELD_
1568 #undef MPP_DO_UPDATE_AD_3D_V_
1569 #define MPP_DO_UPDATE_AD_3D_V_ mpp_do_update_ad_r4_3dv
1570 #endif
1571 #include <mpp_do_update_ad.h>
1572 #include <mpp_do_updateV_ad.h>
1573 #endif
1574 
1575 #ifdef OVERLOAD_C4
1576 #undef VECTOR_FIELD_
1577 #undef MPP_TYPE_
1578 #define MPP_TYPE_ complex(FLOAT_KIND)
1579 #undef MPP_DO_UPDATE_AD_3D_
1580 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_c4_3d
1581 #include <mpp_do_update_ad.h>
1582 #define VECTOR_FIELD_
1583 #endif
1584 
1585 #undef MPP_TYPE_
1586 #define MPP_TYPE_ integer(INT_KIND)
1587 #undef MPP_DO_UPDATE_AD_3D_
1588 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_i4_3d
1589 #include <mpp_do_update_ad.h>
1590 !!$#undef VECTOR_FIELD_
1591 !!$#define VECTOR_FIELD_
1592 !!$#undef MPP_TYPE_
1593 !!$#define MPP_TYPE_ real(DOUBLE_KIND)
1594 !!$#undef MPP_DO_UPDATE_AD_3D_
1595 !!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_r8_3d
1596 !!$#ifdef VECTOR_FIELD_
1597 !!$#undef MPP_DO_UPDATE_AD_3D_V_
1598 !!$#define MPP_DO_UPDATE_AD_3D_V_ mpp_do_update_ad_r8_3dv
1599 !!$#endif
1600 !!$#include <mpp_do_update_ad.h>
1601 !!$#include <mpp_do_updateV_ad.h>
1602 !!$#undef VECTOR_FIELD_
1603 !!$
1604 !!$#ifdef OVERLOAD_C8
1605 !!$#undef MPP_TYPE_
1606 !!$#define MPP_TYPE_ complex(DOUBLE_KIND)
1607 !!$#undef MPP_DO_UPDATE_AD_3D_
1608 !!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_c8_3d
1609 !!$#include <mpp_do_update_ad.h>
1610 !!$#endif
1611 !!$
1612 !!$#ifndef no_8byte_integers
1613 !!$#undef MPP_TYPE_
1614 !!$#define MPP_TYPE_ integer(LONG_KIND)
1615 !!$#undef MPP_DO_UPDATE_AD_3D_
1616 !!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_i8_3d
1617 !!$#include <mpp_do_update_ad.h>
1618 !!$#endif
1619 !!$
1620 !!$#ifdef OVERLOAD_R4
1621 !!$#undef VECTOR_FIELD_
1622 !!$#define VECTOR_FIELD_
1623 !!$#undef MPP_TYPE_
1624 !!$#define MPP_TYPE_ real(FLOAT_KIND)
1625 !!$#undef MPP_DO_UPDATE_AD_3D_
1626 !!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_r4_3d
1627 !!$#ifdef VECTOR_FIELD_
1628 !!$#undef MPP_DO_UPDATE_AD_3D_V_
1629 !!$#define MPP_DO_UPDATE_AD_3D_V_ mpp_do_update_ad_r4_3dv
1630 !!$#endif
1631 !!$#include <mpp_do_update_ad.h>
1632 !!$#include <mpp_do_updateV_ad.h>
1633 !!$#endif
1634 !!$
1635 !!$#ifdef OVERLOAD_C4
1636 !!$#undef VECTOR_FIELD_
1637 !!$#undef MPP_TYPE_
1638 !!$#define MPP_TYPE_ complex(FLOAT_KIND)
1639 !!$#undef MPP_DO_UPDATE_AD_3D_
1640 !!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_c4_3d
1641 !!$#include <mpp_do_update_ad.h>
1642 !!$#endif
1643 !!$
1644 !!$#undef MPP_TYPE_
1645 !!$#define MPP_TYPE_ integer(INT_KIND)
1646 !!$#undef MPP_DO_UPDATE_AD_3D_
1647 !!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_i4_3d
1648 !!$#include <mpp_do_update_ad.h>
1649 
1650 !bnc
1651 
1652 
1653 !********************************************************
1654 #undef MPP_TYPE_
1655 #define MPP_TYPE_ real(DOUBLE_KIND)
1656 #undef MPP_DO_REDISTRIBUTE_3D_
1657 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_r8_3D
1658 #include <mpp_do_redistribute.h>
1659 #undef VECTOR_FIELD_
1660 
1661 #ifdef OVERLOAD_C8
1662 #undef MPP_TYPE_
1663 #define MPP_TYPE_ complex(DOUBLE_KIND)
1664 #undef MPP_DO_REDISTRIBUTE_3D_
1665 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_c8_3D
1666 #include <mpp_do_redistribute.h>
1667 #endif
1668 
1669 #ifndef no_8byte_integers
1670 #undef MPP_TYPE_
1671 #define MPP_TYPE_ integer(LONG_KIND)
1672 #undef MPP_DO_REDISTRIBUTE_3D_
1673 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_i8_3D
1674 #include <mpp_do_redistribute.h>
1675 
1676 #undef MPP_TYPE_
1677 #define MPP_TYPE_ logical(LONG_KIND)
1678 #undef MPP_DO_REDISTRIBUTE_3D_
1679 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_l8_3D
1680 #include <mpp_do_redistribute.h>
1681 #endif
1682 
1683 #ifdef OVERLOAD_R4
1684 #undef MPP_TYPE_
1685 #define MPP_TYPE_ real(FLOAT_KIND)
1686 #undef MPP_DO_REDISTRIBUTE_3D_
1687 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_r4_3D
1688 #include <mpp_do_redistribute.h>
1689 #undef VECTOR_FIELD_
1690 #endif
1691 
1692 #ifdef OVERLOAD_C4
1693 #undef MPP_TYPE_
1694 #define MPP_TYPE_ complex(FLOAT_KIND)
1695 #undef MPP_DO_REDISTRIBUTE_3D_
1696 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_c4_3D
1697 #include <mpp_do_redistribute.h>
1698 #endif
1699 
1700 #undef MPP_TYPE_
1701 #define MPP_TYPE_ integer(INT_KIND)
1702 #undef MPP_DO_REDISTRIBUTE_3D_
1703 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_i4_3D
1704 #include <mpp_do_redistribute.h>
1705 
1706 #undef MPP_TYPE_
1707 #define MPP_TYPE_ logical(INT_KIND)
1708 #undef MPP_DO_REDISTRIBUTE_3D_
1709 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_l4_3D
1710 #include <mpp_do_redistribute.h>
1711 
1712 #undef MPP_TYPE_
1713 #define MPP_TYPE_ real(DOUBLE_KIND)
1714 #undef MPP_GET_BOUNDARY_2D_
1715 #define MPP_GET_BOUNDARY_2D_ mpp_get_boundary_r8_2d
1716 #undef MPP_GET_BOUNDARY_3D_
1717 #define MPP_GET_BOUNDARY_3D_ mpp_get_boundary_r8_3d
1718 !#undef MPP_GET_BOUNDARY_4D_
1719 !#define MPP_GET_BOUNDARY_4D_ mpp_get_boundary_r8_4d
1720 !#undef MPP_GET_BOUNDARY_5D_
1721 !#define MPP_GET_BOUNDARY_5D_ mpp_get_boundary_r8_5d
1722 #undef MPP_GET_BOUNDARY_2D_V_
1723 #define MPP_GET_BOUNDARY_2D_V_ mpp_get_boundary_r8_2dv
1724 #undef MPP_GET_BOUNDARY_3D_V_
1725 #define MPP_GET_BOUNDARY_3D_V_ mpp_get_boundary_r8_3dv
1726 !#undef MPP_GET_BOUNDARY_4D_V_
1727 !#define MPP_GET_BOUNDARY_4D_V_ mpp_get_boundary_r8_4dv
1728 !#undef MPP_GET_BOUNDARY_5D_V_
1729 !#define MPP_GET_BOUNDARY_5D_V_ mpp_get_boundary_r8_5dv
1730 #include <mpp_get_boundary.h>
1731 
1732 #undef MPP_TYPE_
1733 #define MPP_TYPE_ real(DOUBLE_KIND)
1734 #undef MPP_GET_BOUNDARY_AD_2D_
1735 #define MPP_GET_BOUNDARY_AD_2D_ mpp_get_boundary_ad_r8_2d
1736 #undef MPP_GET_BOUNDARY_AD_3D_
1737 #define MPP_GET_BOUNDARY_AD_3D_ mpp_get_boundary_ad_r8_3d
1738 #undef MPP_GET_BOUNDARY_AD_2D_V_
1739 #define MPP_GET_BOUNDARY_AD_2D_V_ mpp_get_boundary_ad_r8_2dv
1740 #undef MPP_GET_BOUNDARY_AD_3D_V_
1741 #define MPP_GET_BOUNDARY_AD_3D_V_ mpp_get_boundary_ad_r8_3dv
1742 #include <mpp_get_boundary_ad.h>
1743 
1744 #ifdef OVERLOAD_R4
1745 #undef MPP_TYPE_
1746 #define MPP_TYPE_ real(FLOAT_KIND)
1747 #undef MPP_GET_BOUNDARY_2D_
1748 #define MPP_GET_BOUNDARY_2D_ mpp_get_boundary_r4_2d
1749 #undef MPP_GET_BOUNDARY_3D_
1750 #define MPP_GET_BOUNDARY_3D_ mpp_get_boundary_r4_3d
1751 !#undef MPP_GET_BOUNDARY_4D_
1752 !#define MPP_GET_BOUNDARY_4D_ mpp_get_boundary_r4_4d
1753 !#undef MPP_GET_BOUNDARY_5D_
1754 !#define MPP_GET_BOUNDARY_5D_ mpp_get_boundary_r4_5d
1755 #undef MPP_GET_BOUNDARY_2D_V_
1756 #define MPP_GET_BOUNDARY_2D_V_ mpp_get_boundary_r4_2dv
1757 #undef MPP_GET_BOUNDARY_3D_V_
1758 #define MPP_GET_BOUNDARY_3D_V_ mpp_get_boundary_r4_3dv
1759 !#undef MPP_GET_BOUNDARY_4D_V_
1760 !#define MPP_GET_BOUNDARY_4D_V_ mpp_get_boundary_r4_4dv
1761 !#undef MPP_GET_BOUNDARY_5D_V_
1762 !#define MPP_GET_BOUNDARY_5D_V_ mpp_get_boundary_r4_5dv
1763 #include <mpp_get_boundary.h>
1764 #endif
1765 
1766 #ifdef OVERLOAD_R4
1767 #undef MPP_TYPE_
1768 #define MPP_TYPE_ real(FLOAT_KIND)
1769 #undef MPP_GET_BOUNDARY_AD_2D_
1770 #define MPP_GET_BOUNDARY_AD_2D_ mpp_get_boundary_ad_r4_2d
1771 #undef MPP_GET_BOUNDARY_AD_3D_
1772 #define MPP_GET_BOUNDARY_AD_3D_ mpp_get_boundary_ad_r4_3d
1773 #undef MPP_GET_BOUNDARY_AD_2D_V_
1774 #define MPP_GET_BOUNDARY_AD_2D_V_ mpp_get_boundary_ad_r4_2dv
1775 #undef MPP_GET_BOUNDARY_AD_3D_V_
1776 #define MPP_GET_BOUNDARY_AD_3D_V_ mpp_get_boundary_ad_r4_3dv
1777 #include <mpp_get_boundary_ad.h>
1778 #endif
1779 
1780 #undef MPP_TYPE_
1781 #define MPP_TYPE_ real(DOUBLE_KIND)
1782 #undef MPP_DO_GET_BOUNDARY_3D_
1783 #define MPP_DO_GET_BOUNDARY_3D_ mpp_do_get_boundary_r8_3d
1784 #undef MPP_DO_GET_BOUNDARY_3DV_
1785 #define MPP_DO_GET_BOUNDARY_3D_V_ mpp_do_get_boundary_r8_3dv
1786 #include <mpp_do_get_boundary.h>
1787 
1788 #undef MPP_TYPE_
1789 #define MPP_TYPE_ real(DOUBLE_KIND)
1790 #undef MPP_DO_GET_BOUNDARY_AD_3D_
1791 #define MPP_DO_GET_BOUNDARY_AD_3D_ mpp_do_get_boundary_ad_r8_3d
1792 #undef MPP_DO_GET_BOUNDARY_AD_3DV_
1793 #define MPP_DO_GET_BOUNDARY_AD_3D_V_ mpp_do_get_boundary_ad_r8_3dv
1794 #include <mpp_do_get_boundary_ad.h>
1795 
1796 #ifdef OVERLOAD_R4
1797 #undef MPP_TYPE_
1798 #define MPP_TYPE_ real(FLOAT_KIND)
1799 #undef MPP_DO_GET_BOUNDARY_3D_
1800 #define MPP_DO_GET_BOUNDARY_3D_ mpp_do_get_boundary_r4_3d
1801 #undef MPP_DO_GET_BOUNDARY_3D_V_
1802 #define MPP_DO_GET_BOUNDARY_3D_V_ mpp_do_get_boundary_r4_3dv
1803 #include <mpp_do_get_boundary.h>
1804 #endif
1805 
1806 #ifdef OVERLOAD_R4
1807 #undef MPP_TYPE_
1808 #define MPP_TYPE_ real(FLOAT_KIND)
1809 #undef MPP_DO_GET_BOUNDARY_AD_3D_
1810 #define MPP_DO_GET_BOUNDARY_AD_3D_ mpp_do_get_boundary_ad_r4_3d
1811 #undef MPP_DO_GET_BOUNDARY_AD_3D_V_
1812 #define MPP_DO_GET_BOUNDARY_AD_3D_V_ mpp_do_get_boundary_ad_r4_3dv
1813 #include <mpp_do_get_boundary_ad.h>
1814 #endif
1815 
1816 #undef MPP_TYPE_
1817 #define MPP_TYPE_ real(DOUBLE_KIND)
1818 #undef MPI_TYPE_
1819 #define MPI_TYPE_ MPI_REAL8
1820 #undef MPP_CREATE_GROUP_UPDATE_2D_
1821 #define MPP_CREATE_GROUP_UPDATE_2D_ mpp_create_group_update_r8_2d
1822 #undef MPP_CREATE_GROUP_UPDATE_3D_
1823 #define MPP_CREATE_GROUP_UPDATE_3D_ mpp_create_group_update_r8_3d
1824 #undef MPP_CREATE_GROUP_UPDATE_4D_
1825 #define MPP_CREATE_GROUP_UPDATE_4D_ mpp_create_group_update_r8_4d
1826 #undef MPP_CREATE_GROUP_UPDATE_2D_V_
1827 #define MPP_CREATE_GROUP_UPDATE_2D_V_ mpp_create_group_update_r8_2dv
1828 #undef MPP_CREATE_GROUP_UPDATE_3D_V_
1829 #define MPP_CREATE_GROUP_UPDATE_3D_V_ mpp_create_group_update_r8_3dv
1830 #undef MPP_CREATE_GROUP_UPDATE_4D_V_
1831 #define MPP_CREATE_GROUP_UPDATE_4D_V_ mpp_create_group_update_r8_4dv
1832 #undef MPP_DO_GROUP_UPDATE_
1833 #define MPP_DO_GROUP_UPDATE_ mpp_do_group_update_r8
1834 #undef MPP_START_GROUP_UPDATE_
1835 #define MPP_START_GROUP_UPDATE_ mpp_start_group_update_r8
1836 #undef MPP_COMPLETE_GROUP_UPDATE_
1837 #define MPP_COMPLETE_GROUP_UPDATE_ mpp_complete_group_update_r8
1838 #undef MPP_RESET_GROUP_UPDATE_FIELD_2D_
1839 #define MPP_RESET_GROUP_UPDATE_FIELD_2D_ mpp_reset_group_update_field_r8_2d
1840 #undef MPP_RESET_GROUP_UPDATE_FIELD_3D_
1841 #define MPP_RESET_GROUP_UPDATE_FIELD_3D_ mpp_reset_group_update_field_r8_3d
1842 #undef MPP_RESET_GROUP_UPDATE_FIELD_4D_
1843 #define MPP_RESET_GROUP_UPDATE_FIELD_4D_ mpp_reset_group_update_field_r8_4d
1844 #undef MPP_RESET_GROUP_UPDATE_FIELD_2D_V_
1845 #define MPP_RESET_GROUP_UPDATE_FIELD_2D_V_ mpp_reset_group_update_field_r8_2dv
1846 #undef MPP_RESET_GROUP_UPDATE_FIELD_3D_V_
1847 #define MPP_RESET_GROUP_UPDATE_FIELD_3D_V_ mpp_reset_group_update_field_r8_3dv
1848 #undef MPP_RESET_GROUP_UPDATE_FIELD_4D_V_
1849 #define MPP_RESET_GROUP_UPDATE_FIELD_4D_V_ mpp_reset_group_update_field_r8_4dv
1850 #include <mpp_group_update.h>
1851 
1852 #undef MPP_TYPE_
1853 #define MPP_TYPE_ real(FLOAT_KIND)
1854 #undef MPI_TYPE_
1855 #define MPI_TYPE_ MPI_REAL4
1856 #undef MPP_CREATE_GROUP_UPDATE_2D_
1857 #define MPP_CREATE_GROUP_UPDATE_2D_ mpp_create_group_update_r4_2d
1858 #undef MPP_CREATE_GROUP_UPDATE_3D_
1859 #define MPP_CREATE_GROUP_UPDATE_3D_ mpp_create_group_update_r4_3d
1860 #undef MPP_CREATE_GROUP_UPDATE_4D_
1861 #define MPP_CREATE_GROUP_UPDATE_4D_ mpp_create_group_update_r4_4d
1862 #undef MPP_CREATE_GROUP_UPDATE_2D_V_
1863 #define MPP_CREATE_GROUP_UPDATE_2D_V_ mpp_create_group_update_r4_2dv
1864 #undef MPP_CREATE_GROUP_UPDATE_3D_V_
1865 #define MPP_CREATE_GROUP_UPDATE_3D_V_ mpp_create_group_update_r4_3dv
1866 #undef MPP_CREATE_GROUP_UPDATE_4D_V_
1867 #define MPP_CREATE_GROUP_UPDATE_4D_V_ mpp_create_group_update_r4_4dv
1868 #undef MPP_DO_GROUP_UPDATE_
1869 #define MPP_DO_GROUP_UPDATE_ mpp_do_group_update_r4
1870 #undef MPP_START_GROUP_UPDATE_
1871 #define MPP_START_GROUP_UPDATE_ mpp_start_group_update_r4
1872 #undef MPP_COMPLETE_GROUP_UPDATE_
1873 #define MPP_COMPLETE_GROUP_UPDATE_ mpp_complete_group_update_r4
1874 #undef MPP_RESET_GROUP_UPDATE_FIELD_2D_
1875 #define MPP_RESET_GROUP_UPDATE_FIELD_2D_ mpp_reset_group_update_field_r4_2d
1876 #undef MPP_RESET_GROUP_UPDATE_FIELD_3D_
1877 #define MPP_RESET_GROUP_UPDATE_FIELD_3D_ mpp_reset_group_update_field_r4_3d
1878 #undef MPP_RESET_GROUP_UPDATE_FIELD_4D_
1879 #define MPP_RESET_GROUP_UPDATE_FIELD_4D_ mpp_reset_group_update_field_r4_4d
1880 #undef MPP_RESET_GROUP_UPDATE_FIELD_2D_V_
1881 #define MPP_RESET_GROUP_UPDATE_FIELD_2D_V_ mpp_reset_group_update_field_r4_2dv
1882 #undef MPP_RESET_GROUP_UPDATE_FIELD_3D_V_
1883 #define MPP_RESET_GROUP_UPDATE_FIELD_3D_V_ mpp_reset_group_update_field_r4_3dv
1884 #undef MPP_RESET_GROUP_UPDATE_FIELD_4D_V_
1885 #define MPP_RESET_GROUP_UPDATE_FIELD_4D_V_ mpp_reset_group_update_field_r4_4dv
1886 #include <mpp_group_update.h>
data_override_mod::undef
integer, parameter undef
Definition: data_override.F90:136
mpp_domains_mod::mpp_domains_stack_hwm
integer mpp_domains_stack_hwm
Definition: mpp_domains.F90:613
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
FLOAT_KIND
#define FLOAT_KIND
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
i
l_size ! loop over number of fields ke do je do i
Definition: mpp_do_redistribute.h:71
PE
l_size ! loop over number of fields ke do je do ie to PE
Definition: mpp_do_redistribute.h:72
unit
************************************************************************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=> unit
Definition: mpp_read_2Ddecomp.h:167
mpp_domains_mod::nest_wait_clock
integer nest_wait_clock
Definition: mpp_domains.F90:677
mpp_domains_mod::domain_clocks_on
logical domain_clocks_on
Definition: mpp_domains.F90:671
mpp_domains_mod::nonblock_group_unpk_clock
integer nonblock_group_unpk_clock
Definition: mpp_domains.F90:680
mpp_domains_mod::group_pack_clock
integer group_pack_clock
Definition: mpp_domains.F90:678
mpp_io_mod::unit_begin
integer unit_begin
Definition: mpp_io.F90:1047
mpp_io_mod::unit_end
integer unit_end
Definition: mpp_io.F90:1047
fms_io_mod::je
integer, private je
Definition: fms_io.F90:494
mpp_domains_mod::group_unpk_clock
integer group_unpk_clock
Definition: mpp_domains.F90:678
oda_core_mod::iec
integer, save, private iec
Definition: oda_core.F90:124
crtm_lowfrequency_mwssem::n
integer n
Definition: CRTM_LowFrequency_MWSSEM.f90:172
crtm_parameters::no
integer, parameter, public no
Definition: CRTM_Parameters.f90:112
fms_io_mod::jsd
integer, private jsd
Definition: fms_io.F90:495
azimuth_emissivity_f6_module::two
real(fp), parameter two
Definition: Azimuth_Emissivity_F6_Module.f90:48
mpp_parameter_mod::recv
integer, parameter recv
Definition: mpp_parameter.F90:99
mpp_domains_mod::nonblock_group_send_clock
integer nonblock_group_send_clock
Definition: mpp_domains.F90:679
allocatable
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_WRITE_UNLIMITED_AXIS_1D_(unit, field, domain, data, nelems_io) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:) integer, intent(in) ::nelems_io(:) ! number of compressed elements from each ! member of the io_domain. It MUST have the ! same order as the io_domain pelist. integer, allocatable ::pelist(:) integer ::i, j, nelems, npes type(domain2d), pointer ::io_domain=> allocatable
Definition: mpp_write_unlimited_axis.h:30
npes
int npes
Definition: threadloc.c:26
fv3jedi_increment_mod::copy
subroutine, public copy(self, rhs)
Definition: fv3jedi_increment_mod.f90:254
mpp_domains_mod::nest_pack_clock
integer nest_pack_clock
Definition: mpp_domains.F90:677
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
cloudcoeff_define::set
integer, parameter set
Definition: CloudCoeff_Define.f90:63
mpp_domains_mod::nonblock_group_pack_clock
integer nonblock_group_pack_clock
Definition: mpp_domains.F90:679
binary_file_utility::true
integer(long), parameter true
Definition: Binary_File_Utility.f90:61
TLM_vs_NLM.im
im
Definition: TLM_vs_NLM.py:47
domain_in
************************************************************************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_DO_REDISTRIBUTE_3D_(f_in, f_out, d_comm, d_type) integer(LONG_KIND), intent(in) ::f_in(:), f_out(:) type(DomainCommunicator2D), intent(in) ::d_comm MPP_TYPE_, intent(in) ::d_type MPP_TYPE_ ::field_in(d_comm%domain_in%x(1)%data%begin:d_comm%domain_in%x(1)%data%end, &d_comm%domain_in%y(1)%data%begin:d_comm%domain_in%y(1)%data%end, d_comm%ke) pointer(ptr_field_in, field_in) MPP_TYPE_ ::field_out(d_comm%domain_out%x(1)%data%begin:d_comm%domain_out%x(1)%data%end, &d_comm%domain_out%y(1)%data%begin:d_comm%domain_out%y(1)%data%end, d_comm%ke) pointer(ptr_field_out, field_out) type(domain2D), pointer ::domain_in, domain_out integer ::i, j, k, l, n, l_size integer ::is, ie, js, je integer ::ke integer ::list, pos, msgsize integer ::to_pe, from_pe MPP_TYPE_ ::buffer(size(mpp_domains_stack(:))) pointer(ptr, buffer) integer ::buffer_pos, wordlen, errunit!fix ke errunit=stderr() l_size=size(f_out(:)) ! equal to size(f_in(:)) ke=d_comm%ke domain_in=> d_comm domain_in
Definition: mpp_do_redistribute.h:4
make_check_data.out
out
Definition: make_check_data.py:458
TLM_vs_NLM.jm
jm
Definition: TLM_vs_NLM.py:48
fms_io_mod::ieg
integer, private ieg
Definition: fms_io.F90:496
mpp_domains_mod::nest_unpk_clock
integer nest_unpk_clock
Definition: mpp_domains.F90:676
gsw_mod_check_data::p
real(r8), dimension(cast_m, cast_n) p
Definition: gsw_mod_check_data.f90:247
mpp_domains_mod::group_send_clock
integer group_send_clock
Definition: mpp_domains.F90:678
binary_file_utility::false
integer(long), parameter false
Definition: Binary_File_Utility.f90:60
from_pe
from from_pe
Definition: mpp_do_redistribute.h:93
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
j
l_size ! loop over number of fields ke do j
Definition: mpp_do_redistribute.h:70
mpp_parameter_mod::send
integer, parameter send
Definition: mpp_parameter.F90:99
mpp_parameter_mod::west
integer, parameter, public west
Definition: mpp_parameter.F90:95
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
amip_interp_mod::module_is_initialized
logical module_is_initialized
Definition: amip_interp.F90:272
fms_io_mod::jed
integer, private jed
Definition: fms_io.F90:495
to_pe
l_size ! loop over number of fields ke do je do ie to to_pe
Definition: mpp_do_redistribute.h:72
mpp_pset_mod::mpp_pset_init
subroutine, public mpp_pset_init
Definition: mpp_pset.F90:104
mpp_domains_mod
Definition: mpp_domains.F90:128
mersennetwister_mod::m
integer, parameter m
Definition: MersenneTwister.F90:79
ensemble_manager_mod::pe
integer pe
Definition: ensemble_manager.F90:50
mpp_mod::input_nml_file
character(len=input_str_length), dimension(:), allocatable, target, public input_nml_file
Definition: mpp.F90:1378
mpp_domains_mod::nest_send_clock
integer nest_send_clock
Definition: mpp_domains.F90:676
mpp_domains_mod::wait_clock
integer wait_clock
Definition: mpp_domains.F90:673
domain_out
domain_out
Definition: mpp_do_redistribute.h:43
diag_integral_mod::version
character(len=128) version
Definition: diag_integral.F90:121
mpp_domains_mod::recv_clock_nonblock
integer recv_clock_nonblock
Definition: mpp_domains.F90:674
mpp_domains_mod::send_pack_clock_nonblock
integer send_pack_clock_nonblock
Definition: mpp_domains.F90:674
mpp_mod::debug
logical debug
Definition: mpp.F90:1297
is
l_size ! loop over number of fields ke do je do ie to is
Definition: mpp_do_redistribute.h:72
c2f.output
output
Definition: c2f.py:20
c2f.type
type
Definition: c2f.py:15
mpp_parameter_mod::global
integer, parameter, public global
Definition: mpp_parameter.F90:94
mpp_domains_mod::recv_clock
integer recv_clock
Definition: mpp_domains.F90:672
mpp_domains_mod::nest_recv_clock
integer nest_recv_clock
Definition: mpp_domains.F90:676
field_manager_mod::initialize
subroutine, private initialize
Definition: field_manager.F90:5419
fms_io_mod::ied
integer, private ied
Definition: fms_io.F90:495
mpp_domains_mod::nonblock_group_wait_clock
integer nonblock_group_wait_clock
Definition: mpp_domains.F90:680
fms_io_mod::ie
integer, private ie
Definition: fms_io.F90:494
fv3jedi_geom_mod::info
subroutine, public info(self)
Definition: fv3jedi_geom_mod.f90:494
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
gsw_mod_sp_coefficients::k
real(r8), parameter k
Definition: gsw_mod_sp_coefficients.f90:40
fms_io_mod::isg
integer, private isg
Definition: fms_io.F90:496
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
mpp_domains_mod::group_wait_clock
integer group_wait_clock
Definition: mpp_domains.F90:678
mpp_parameter_mod::east
integer, parameter, public east
Definition: mpp_parameter.F90:95
mpp_domains_mod::send_clock
integer send_clock
Definition: mpp_domains.F90:672
fms_io_mod::jeg
integer, private jeg
Definition: fms_io.F90:496
fv_control_nlm_mod::fill
logical, pointer fill
Definition: fv_control_nlm.F90:170
mpp_domains_mod::group_recv_clock
integer group_recv_clock
Definition: mpp_domains.F90:678
mpp_domains_mod::pack_clock
integer pack_clock
Definition: mpp_domains.F90:673
POINTER_KIND
#define POINTER_KIND
type_distribution::received
logical function received(this, seqno)
Definition: m_distribution.f90:72
conf.release
string release
Definition: conf.py:67
fv3jedi_increment_mod::check
subroutine check(self)
Definition: fv3jedi_increment_mod.f90:1932
interpolator_mod::len
integer len
Definition: interpolator.F90:321
oda_core_mod::isc
integer, save, private isc
Definition: oda_core.F90:124
LONG_KIND
#define LONG_KIND
field_manager_mod::root
type(field_def), target, save root
Definition: field_manager.F90:564
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
mpp_mod::request_recv
integer, dimension(:), allocatable request_recv
Definition: mpp.F90:1320
size
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this ! since that attempts to gather all data on PE size(field%axes(:)) axsiz(i)
mpp_domains_mod::debug_update_domain
character(len=32) debug_update_domain
Definition: mpp_domains.F90:701
mpp_domains_mod::wait_clock_nonblock
integer wait_clock_nonblock
Definition: mpp_domains.F90:675
mpp_parameter_mod::north
integer, parameter, public north
Definition: mpp_parameter.F90:95
oda_core_mod::jsc
integer, save, private jsc
Definition: oda_core.F90:124
fms_io_mod::jsg
integer, private jsg
Definition: fms_io.F90:496
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
max
#define max(a, b)
Definition: mosaic_util.h:33
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)
mpp_domains_mod::nonblock_data
type(nonblock_type), dimension(:), allocatable nonblock_data
Definition: mpp_domains.F90:624
mpp_mod::size_recv
integer, dimension(:), allocatable size_recv
Definition: mpp.F90:1321
gsw_mod_check_data::t
real(r8), dimension(cast_m, cast_n) t
Definition: gsw_mod_check_data.f90:224
station_data_mod::pelist
integer, dimension(:), allocatable pelist
Definition: station_data.F90:293
not
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If not
Definition: drifters_compute_k.h:5
INT_KIND
#define INT_KIND
MPI_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 MPI_TYPE_
Definition: mpp_transmit_mpi.h:81
make_check_data.d
d
Definition: make_check_data.py:448
oda_core_mod::jec
integer, save, private jec
Definition: oda_core.F90:124
pos
l_size ! loop over number of fields ke do je do ie pos
Definition: mpp_do_redistribute.h:72
mpp_mod::request_send
integer, dimension(:), allocatable request_send
Definition: mpp.F90:1319
min
#define min(a, b)
Definition: mosaic_util.h:32
mpp_parameter_mod::south
integer, parameter, public south
Definition: mpp_parameter.F90:95
fms_io_mod::isd
integer, private isd
Definition: fms_io.F90:495
DOUBLE_KIND
#define DOUBLE_KIND
mpp_domains_mod::nonblock_group_recv_clock
integer nonblock_group_recv_clock
Definition: mpp_domains.F90:679
xgrid_mod::some
subroutine, public some(xmap, some_arr, grid_id)
Definition: xgrid.F90:3421
mpp_domains_mod::unpk_clock
integer unpk_clock
Definition: mpp_domains.F90:672
fv_control_nlm_mod::ntiles
integer, pointer ntiles
Definition: fv_control_nlm.F90:149
js
l_size ! loop over number of fields ke do je do ie to js
Definition: mpp_do_redistribute.h:72
oda_core_mod::lowercase
character(len=len(cs)) function lowercase(cs)
Definition: oda_core.F90:1415
mpp_domains_mod::unpk_clock_nonblock
integer unpk_clock_nonblock
Definition: mpp_domains.F90:674
tools_repro::eq
logical function, public eq(x, y)
Definition: tools_repro.F90:28
mpp_domains_mod::debug_update_level
integer debug_update_level
Definition: mpp_domains.F90:712
mpp_mod::type_recv
integer, dimension(:), allocatable type_recv
Definition: mpp.F90:1322
amip_interp_mod::verbose
integer verbose
Definition: amip_interp.F90:354
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