FV3 Bundle
mpp_do_updateV_ad.h
Go to the documentation of this file.
1 ! -*-f90-*-
2 
3 
4 !***********************************************************************
5 !* GNU Lesser General Public License
6 !*
7 !* This file is part of the GFDL Flexible Modeling System (FMS).
8 !*
9 !* FMS is free software: you can redistribute it and/or modify it under
10 !* the terms of the GNU Lesser General Public License as published by
11 !* the Free Software Foundation, either version 3 of the License, or (at
12 !* your option) any later version.
13 !*
14 !* FMS is distributed in the hope that it will be useful, but WITHOUT
15 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 !* for more details.
18 !*
19 !* You should have received a copy of the GNU Lesser General Public
20 !* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
21 !***********************************************************************
22 
23  subroutine MPP_DO_UPDATE_AD_3D_V_(f_addrsx,f_addrsy, domain, update_x, update_y, &
24  d_type, ke, gridtype, flags)
25 !updates data domain of 3D field whose computational domains have been computed
26  integer(LONG_KIND), intent(in) :: f_addrsx(:,:), f_addrsy(:,:)
27  type(domain2d), intent(in) :: domain
28  type(overlapSpec), intent(in) :: update_x, update_y
29  integer, intent(in) :: ke
30  MPP_TYPE_, intent(in) :: d_type ! creates unique interface
31  integer, intent(in) :: gridtype
32  integer, intent(in), optional :: flags
33 
34  MPP_TYPE_ :: fieldx(update_x%xbegin:update_x%xend, update_x%ybegin:update_x%yend,ke)
35  MPP_TYPE_ :: fieldy(update_y%xbegin:update_y%xend, update_y%ybegin:update_y%yend,ke)
36  pointer(ptr_fieldx, fieldx)
37  pointer(ptr_fieldy, fieldy)
38 
39  integer :: update_flags
40  integer :: l_size, l, i, j, k, is, ie, js, je, n, m
41  integer :: pos, nlist, msgsize
42  integer :: to_pe, from_pe, midpoint
43  integer :: tMe, dir
44 
45  integer :: send_start_pos, nsend
46  integer :: send_msgsize(2*MAXLIST)
47  integer :: send_pe(2*MAXLIST)
48  integer, allocatable :: msg1(:), msg2(:)
49  logical :: send(8), recv(8), update_edge_only
50  MPP_TYPE_ :: buffer(size(mpp_domains_stack(:)))
51  pointer(ptr,buffer )
52  integer :: buffer_pos
53  character(len=8) :: text
54  integer :: buffer_recv_size, shift
55  integer :: rank_x, rank_y, ind_x, ind_y, cur_rank
56  integer :: nsend_x, nsend_y, nrecv_x, nrecv_y, outunit
57 
58  outunit = stdout()
59  update_flags = XUPDATE+YUPDATE !default
60  if( PRESENT(flags) ) then
61  update_flags = flags
62  ! The following test is so that SCALAR_PAIR can be used alone with the
63  ! same default update pattern as without.
64  if (BTEST(update_flags,SCALAR_BIT)) then
65  if (.NOT.(BTEST(update_flags,WEST) .OR. BTEST(update_flags,EAST) &
66  .OR. BTEST(update_flags,NORTH) .OR. BTEST(update_flags,SOUTH))) &
67  update_flags = update_flags + XUPDATE+YUPDATE !default with SCALAR_PAIR
68  end if
69  end if
70 
71  if( BTEST(update_flags,NORTH) .AND. BTEST(domain%fold,NORTH) .AND. BTEST(gridtype,SOUTH) ) &
72  call mpp_error( FATAL, 'MPP_DO_UPDATE_V: Incompatible grid offset and fold.' )
73 
74  update_edge_only = BTEST(update_flags, EDGEONLY)
75  recv(1) = BTEST(update_flags,EAST)
76  recv(3) = BTEST(update_flags,SOUTH)
77  recv(5) = BTEST(update_flags,WEST)
78  recv(7) = BTEST(update_flags,NORTH)
79  if( update_edge_only ) then
80  if( .NOT. (recv(1) .OR. recv(3) .OR. recv(5) .OR. recv(7)) ) then
81  recv(1) = .true.
82  recv(3) = .true.
83  recv(5) = .true.
84  recv(7) = .true.
85  endif
86  else
87  recv(2) = recv(1) .AND. recv(3)
88  recv(4) = recv(3) .AND. recv(5)
89  recv(6) = recv(5) .AND. recv(7)
90  recv(8) = recv(7) .AND. recv(1)
91  endif
92 
93  send = recv
94 
95  l_size = size(f_addrsx,1)
96  nlist = size(domain%list(:))
97  ptr = LOC(mpp_domains_stack)
98 
99 !recv
100  nsend_x = update_x%nsend
101  nsend_y = update_y%nsend
102  nrecv_x = update_x%nrecv
103  nrecv_y = update_y%nrecv
104 
105  if(debug_message_passing) then
106  allocate(msg1(0:nlist-1), msg2(0:nlist-1) )
107  msg1 = 0
108  msg2 = 0
109  cur_rank = get_rank_recv(domain, update_x, update_y, rank_x, rank_y, ind_x, ind_y)
110 
111  do while (ind_x .LE. nrecv_x .OR. ind_y .LE. nrecv_y)
112  msgsize = 0
113  if(cur_rank == rank_x) then
114  from_pe = update_x%recv(ind_x)%pe
115  do n = 1, update_x%recv(ind_x)%count
116  dir = update_x%recv(ind_x)%dir(n)
117  if(recv(dir)) then
118  is = update_x%recv(ind_x)%is(n); ie = update_x%recv(ind_x)%ie(n)
119  js = update_x%recv(ind_x)%js(n); je = update_x%recv(ind_x)%je(n)
120  msgsize = msgsize + (ie-is+1)*(je-js+1)
121  end if
122  end do
123  ind_x = ind_x+1
124  if(ind_x .LE. nrecv_x) then
125  rank_x = update_x%recv(ind_x)%pe - domain%pe
126  if(rank_x .LE.0) rank_x = rank_x + nlist
127  else
128  rank_x = -1
129  endif
130  endif
131  if(cur_rank == rank_y) then
132  from_pe = update_y%recv(ind_y)%pe
133  do n = 1, update_y%recv(ind_y)%count
134  dir = update_y%recv(ind_y)%dir(n)
135  if(recv(dir)) then
136  is = update_y%recv(ind_y)%is(n); ie = update_y%recv(ind_y)%ie(n)
137  js = update_y%recv(ind_y)%js(n); je = update_y%recv(ind_y)%je(n)
138  msgsize = msgsize + (ie-is+1)*(je-js+1)
139  end if
140  end do
141  ind_y = ind_y+1
142  if(ind_y .LE. nrecv_y) then
143  rank_y = update_y%recv(ind_y)%pe - domain%pe
144  if(rank_y .LE.0) rank_y = rank_y + nlist
145  else
146  rank_y = -1
147  endif
148  endif
149  cur_rank = max(rank_x, rank_y)
150  m = from_pe-mpp_root_pe()
151  call mpp_recv( msg1(m), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_1)
152  msg2(m) = msgsize
153  end do
154 
155  cur_rank = get_rank_send(domain, update_x, update_y, rank_x, rank_y, ind_x, ind_y)
156  do while (ind_x .LE. nsend_x .OR. ind_y .LE. nsend_y)
157  msgsize = 0
158  if(cur_rank == rank_x) then
159  to_pe = update_x%send(ind_x)%pe
160  do n = 1, update_x%send(ind_x)%count
161  dir = update_x%send(ind_x)%dir(n)
162  if( send(dir) ) then
163  is = update_x%send(ind_x)%is(n); ie = update_x%send(ind_x)%ie(n)
164  js = update_x%send(ind_x)%js(n); je = update_x%send(ind_x)%je(n)
165  msgsize = msgsize + (ie-is+1)*(je-js+1)
166  end if
167  end do
168  ind_x = ind_x+1
169  if(ind_x .LE. nsend_x) then
170  rank_x = update_x%send(ind_x)%pe - domain%pe
171  if(rank_x .LT.0) rank_x = rank_x + nlist
172  else
173  rank_x = nlist+1
174  endif
175  endif
176  if(cur_rank == rank_y) then
177  to_pe = update_y%send(ind_y)%pe
178  do n = 1, update_y%send(ind_y)%count
179  dir = update_y%send(ind_y)%dir(n)
180  if( send(dir) ) then
181  is = update_y%send(ind_y)%is(n); ie = update_y%send(ind_y)%ie(n)
182  js = update_y%send(ind_y)%js(n); je = update_y%send(ind_y)%je(n)
183  msgsize = msgsize + (ie-is+1)*(je-js+1)
184  end if
185  end do
186  ind_y = ind_y+1
187  if(ind_y .LE. nsend_y) then
188  rank_y = update_y%send(ind_y)%pe - domain%pe
189  if(rank_y .LT.0) rank_y = rank_y + nlist
190  else
191  rank_y = nlist+1
192  endif
193  endif
194  cur_rank = min(rank_x, rank_y)
195  call mpp_send( msgsize, plen=1, to_pe=to_pe, tag=COMM_TAG_1)
196  enddo
197  call mpp_sync_self(check=EVENT_RECV)
198  do m = 0, nlist-1
199  if(msg1(m) .NE. msg2(m)) then
200  print*, "My pe = ", mpp_pe(), ",domain name =", trim(domain%name), ",from pe=", &
201  domain%list(m)%pe, ":send size = ", msg1(m), ", recv size = ", msg2(m)
202  call mpp_error(FATAL, "mpp_do_updateV: mismatch on send and recv size")
203  endif
204  enddo
205 
206  call mpp_sync_self()
207  write(outunit,*)"NOTE from mpp_do_updateV: message sizes are matched between send and recv for domain " &
208  //trim(domain%name)
209  deallocate(msg1, msg2)
210  endif
211 
212  buffer_pos = 0
213  cur_rank = get_rank_recv(domain, update_x, update_y, rank_x, rank_y, ind_x, ind_y)
214 
215  do while (ind_x .LE. nrecv_x .OR. ind_y .LE. nrecv_y)
216  msgsize = 0
217  select case(gridtype)
218  case(BGRID_NE, BGRID_SW, AGRID)
219  if(cur_rank == rank_x) then
220  from_pe = update_x%recv(ind_x)%pe
221  do n = 1, update_x%recv(ind_x)%count
222  dir = update_x%recv(ind_x)%dir(n)
223  if(recv(dir)) then
224  tMe = update_x%recv(ind_x)%tileMe(n)
225  is = update_x%recv(ind_x)%is(n); ie = update_x%recv(ind_x)%ie(n)
226  js = update_x%recv(ind_x)%js(n); je = update_x%recv(ind_x)%je(n)
227  msgsize = msgsize + (ie-is+1)*(je-js+1)
228  end if
229  end do
230  msgsize = msgsize*2
231  ind_x = ind_x+1
232  ind_y = ind_x
233  if(ind_x .LE. nrecv_x) then
234  rank_x = update_x%recv(ind_x)%pe - domain%pe
235  if(rank_x .LE.0) rank_x = rank_x + nlist
236  else
237  rank_x = -1
238  endif
239  rank_y = rank_x
240  endif
241  case(CGRID_NE, CGRID_SW)
242  if(cur_rank == rank_x) then
243  from_pe = update_x%recv(ind_x)%pe
244  do n = 1, update_x%recv(ind_x)%count
245  dir = update_x%recv(ind_x)%dir(n)
246  if(recv(dir)) then
247  is = update_x%recv(ind_x)%is(n); ie = update_x%recv(ind_x)%ie(n)
248  js = update_x%recv(ind_x)%js(n); je = update_x%recv(ind_x)%je(n)
249  msgsize = msgsize + (ie-is+1)*(je-js+1)
250  end if
251  end do
252  ind_x = ind_x+1
253  if(ind_x .LE. nrecv_x) then
254  rank_x = update_x%recv(ind_x)%pe - domain%pe
255  if(rank_x .LE.0) rank_x = rank_x + nlist
256  else
257  rank_x = -1
258  endif
259  endif
260  if(cur_rank == rank_y) then
261  from_pe = update_y%recv(ind_y)%pe
262  do n = 1, update_y%recv(ind_y)%count
263  dir = update_y%recv(ind_y)%dir(n)
264  if(recv(dir)) then
265  is = update_y%recv(ind_y)%is(n); ie = update_y%recv(ind_y)%ie(n)
266  js = update_y%recv(ind_y)%js(n); je = update_y%recv(ind_y)%je(n)
267  msgsize = msgsize + (ie-is+1)*(je-js+1)
268  end if
269  end do
270  ind_y = ind_y+1
271  if(ind_y .LE. nrecv_y) then
272  rank_y = update_y%recv(ind_y)%pe - domain%pe
273  if(rank_y .LE.0) rank_y = rank_y + nlist
274  else
275  rank_y = -1
276  endif
277  endif
278  end select
279  cur_rank = max(rank_x, rank_y)
280  msgsize = msgsize*ke*l_size
281 
282  if( msgsize.GT.0 )then
283  buffer_pos = buffer_pos + msgsize
284  end if
285  end do
286  buffer_recv_size = buffer_pos
287 
288 !unpacking
289  buffer_pos = buffer_recv_size
290  cur_rank = get_rank_unpack(domain, update_x, update_y, rank_x, rank_y, ind_x, ind_y)
291 
292  do while (ind_x > 0 .OR. ind_y > 0)
293  pos = buffer_pos
294  select case ( gridtype )
295  case(BGRID_NE, BGRID_SW, AGRID)
296  if(cur_rank == rank_x) then
297  do n = update_x%recv(ind_x)%count, 1, -1
298  dir = update_x%recv(ind_x)%dir(n)
299  if( recv(dir) ) then
300  tMe = update_x%recv(ind_x)%tileMe(n)
301  is = update_x%recv(ind_x)%is(n); ie = update_x%recv(ind_x)%ie(n)
302  js = update_x%recv(ind_x)%js(n); je = update_x%recv(ind_x)%je(n)
303  msgsize = (ie-is+1)*(je-js+1)*ke*2*l_size
304  pos = buffer_pos - msgsize
305  buffer_pos = pos
306  do l=1, l_size ! loop over number of fields
307  ptr_fieldx = f_addrsx(l, tMe)
308  ptr_fieldy = f_addrsy(l, tMe)
309  do k = 1,ke
310  do j = js, je
311  do i = is, ie
312  pos = pos + 2
313  buffer(pos-1) = fieldx(i,j,k)
314  buffer(pos) = fieldy(i,j,k)
315  fieldx(i,j,k) = 0.
316  fieldy(i,j,k) = 0.
317  end do
318  end do
319  end do
320  end do
321  end if ! end if( recv(dir) )
322  end do ! do dir=8,1,-1
323  ind_x = ind_x-1
324  ind_y = ind_x
325  if(ind_x .GT. 0) then
326  rank_x = update_x%recv(ind_x)%pe - domain%pe
327  if(rank_x .LE.0) rank_x = rank_x + nlist
328  else
329  rank_x = nlist+1
330  endif
331  rank_y = rank_x
332  endif
333  case(CGRID_NE, CGRID_SW)
334  if(cur_rank == rank_y) then
335  do n = update_y%recv(ind_y)%count, 1, -1
336  dir = update_y%recv(ind_y)%dir(n)
337  if( recv(dir) ) then
338  tMe = update_y%recv(ind_y)%tileMe(n)
339  is = update_y%recv(ind_y)%is(n); ie = update_y%recv(ind_y)%ie(n)
340  js = update_y%recv(ind_y)%js(n); je = update_y%recv(ind_y)%je(n)
341  msgsize = (ie-is+1)*(je-js+1)*ke*l_size
342  pos = buffer_pos - msgsize
343  buffer_pos = pos
344  do l=1,l_size ! loop over number of fields
345  ptr_fieldx = f_addrsx(l, tMe)
346  ptr_fieldy = f_addrsy(l, tMe)
347  do k = 1,ke
348  do j = js, je
349  do i = is, ie
350  pos = pos + 1
351  buffer(pos) = fieldy(i,j,k)
352  fieldy(i,j,k) = 0.
353  end do
354  end do
355  end do
356  end do
357  end if
358  end do
359  ind_y = ind_y-1
360  if(ind_y .GT. 0) then
361  rank_y = update_y%recv(ind_y)%pe - domain%pe
362  if(rank_y .LE.0) rank_y = rank_y + nlist
363  else
364  rank_y = nlist+1
365  endif
366  endif
367  if(cur_rank == rank_x) then
368  do n = update_x%recv(ind_x)%count, 1, -1
369  dir = update_x%recv(ind_x)%dir(n)
370  if( recv(dir) ) then
371  tMe = update_x%recv(ind_x)%tileMe(n)
372  is = update_x%recv(ind_x)%is(n); ie = update_x%recv(ind_x)%ie(n)
373  js = update_x%recv(ind_x)%js(n); je = update_x%recv(ind_x)%je(n)
374  msgsize = (ie-is+1)*(je-js+1)*ke*l_size
375  pos = buffer_pos - msgsize
376  buffer_pos = pos
377  do l=1,l_size ! loop over number of fields
378  ptr_fieldx = f_addrsx(l, tMe)
379  ptr_fieldy = f_addrsy(l, tMe)
380  do k = 1,ke
381  do j = js, je
382  do i = is, ie
383  pos = pos + 1
384  buffer(pos) = fieldx(i,j,k)
385  fieldx(i,j,k) = 0.
386  end do
387  end do
388  end do
389  end do
390  end if
391  end do
392  ind_x = ind_x-1
393  if(ind_x .GT. 0) then
394  rank_x = update_x%recv(ind_x)%pe - domain%pe
395  if(rank_x .LE.0) rank_x = rank_x + nlist
396  else
397  rank_x = nlist+1
398  endif
399  endif
400  end select
401  cur_rank = min(rank_x, rank_y)
402  end do
403 
404  ! ---northern boundary fold
405  shift = 0
406  if(domain%symmetry) shift = 1
407  if( BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(update_flags,SCALAR_BIT)) )then
408  j = domain%y(1)%global%end+shift
409  if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain
410  !poles set to 0: BGRID only
411  if( gridtype.EQ.BGRID_NE )then
412  midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2
413  j = domain%y(1)%global%end+shift
414  is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift
415  if( .NOT. domain%symmetry ) is = is - 1
416  do i = is ,ie, midpoint
417  if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then
418  do l=1,l_size
419  ptr_fieldx = f_addrsx(l, 1)
420  ptr_fieldy = f_addrsy(l, 1)
421  do k = 1,ke
422  fieldx(i,j,k) = 0.
423  fieldy(i,j,k) = 0.
424  end do
425  end do
426  end if
427  end do
428  endif
429 
430  ! the following code code block correct an error where the data in your halo coming from
431  ! other half may have the wrong sign
432  !off west edge, when update north or west direction
433  j = domain%y(1)%global%end+shift
434  if ( recv(7) .OR. recv(5) ) then
435  select case(gridtype)
436  case(BGRID_NE)
437  if(domain%symmetry) then
438  is = domain%x(1)%global%begin
439  else
440  is = domain%x(1)%global%begin - 1
441  end if
442  if( is.GT.domain%x(1)%data%begin )then
443 
444  if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) &
445  call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-north BGRID_NE west edge ubound error.' )
446  do l=1,l_size
447  ptr_fieldx = f_addrsx(l, 1)
448  ptr_fieldy = f_addrsy(l, 1)
449  do k = 1,ke
450  do i = domain%x(1)%data%begin,is-1
451  fieldx(2*is-i,j,k) = fieldx(2*is-i,j,k) + fieldx(i,j,k)
452  fieldy(2*is-i,j,k) = fieldy(2*is-i,j,k) + fieldy(i,j,k)
453  end do
454  end do
455  end do
456  end if
457  case(CGRID_NE)
458  is = domain%x(1)%global%begin
459  if( is.GT.domain%x(1)%data%begin )then
460  if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) &
461  call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-north CGRID_NE west edge ubound error.' )
462  do l=1,l_size
463  ptr_fieldy = f_addrsy(l, 1)
464  do k = 1,ke
465  do i = domain%x(1)%data%begin,is-1
466  fieldy(2*is-i-1,j,k) = fieldy(2*is-i-1,j,k) + fieldy(i,j,k)
467  end do
468  end do
469  end do
470  end if
471  end select
472  end if
473 
474  !off east edge
475  is = domain%x(1)%global%end
476  if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then
477  ie = domain%x(1)%data%end
478  is = is + 1
479  select case(gridtype)
480  case(BGRID_NE)
481  is = is + shift
482  ie = ie + shift
483  do l=1,l_size
484  ptr_fieldx = f_addrsx(l, 1)
485  ptr_fieldy = f_addrsy(l, 1)
486  do k = 1,ke
487  do i = is,ie
488  fieldx(i,j,k) = -fieldx(i,j,k)
489  fieldy(i,j,k) = -fieldy(i,j,k)
490  end do
491  end do
492  end do
493  case(CGRID_NE)
494  do l=1,l_size
495  ptr_fieldy = f_addrsy(l, 1)
496  do k = 1,ke
497  do i = is, ie
498  fieldy(i,j,k) = -fieldy(i,j,k)
499  end do
500  end do
501  end do
502  end select
503  end if
504  end if
505  else if( BTEST(domain%fold,SOUTH) .AND. (.NOT.BTEST(update_flags,SCALAR_BIT)) )then ! ---southern boundary fold
506  ! NOTE: symmetry is assumed for fold-south boundary
507  j = domain%y(1)%global%begin
508  if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain
509  midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2
510  !poles set to 0: BGRID only
511  if( gridtype.EQ.BGRID_NE )then
512  j = domain%y(1)%global%begin
513  is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift
514  do i = is ,ie, midpoint
515  if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then
516  do l=1,l_size
517  ptr_fieldx = f_addrsx(l, 1)
518  ptr_fieldy = f_addrsy(l, 1)
519  do k = 1,ke
520  fieldx(i,j,k) = 0.
521  fieldy(i,j,k) = 0.
522  end do
523  end do
524  end if
525  end do
526  endif
527 
528  ! the following code code block correct an error where the data in your halo coming from
529  ! other half may have the wrong sign
530  !off west edge, when update north or west direction
531  j = domain%y(1)%global%begin
532  if ( recv(3) .OR. recv(5) ) then
533  select case(gridtype)
534  case(BGRID_NE)
535  is = domain%x(1)%global%begin
536  if( is.GT.domain%x(1)%data%begin )then
537 
538  if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) &
539  call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-south BGRID_NE west edge ubound error.' )
540  do l=1,l_size
541  ptr_fieldx = f_addrsx(l, 1)
542  ptr_fieldy = f_addrsy(l, 1)
543  do k = 1,ke
544  do i = domain%x(1)%data%begin,is-1
545  fieldx(2*is-i,j,k) = fieldx(2*is-i,j,k) + fieldx(i,j,k)
546  fieldy(2*is-i,j,k) = fieldy(2*is-i,j,k) + fieldy(i,j,k)
547  end do
548  end do
549  end do
550  end if
551  case(CGRID_NE)
552  is = domain%x(1)%global%begin
553  if( is.GT.domain%x(1)%data%begin )then
554  if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) &
555  call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-south CGRID_NE west edge ubound error.' )
556  do l=1,l_size
557  ptr_fieldy = f_addrsy(l, 1)
558  do k = 1,ke
559  do i = domain%x(1)%data%begin,is-1
560  fieldy(2*is-i-1,j,k) = fieldy(2*is-i-1,j,k) + fieldy(i,j,k)
561  end do
562  end do
563  end do
564  end if
565  end select
566  end if
567 
568  !off east edge
569  is = domain%x(1)%global%end
570  if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then
571  ie = domain%x(1)%data%end
572  is = is + 1
573  select case(gridtype)
574  case(BGRID_NE)
575  is = is + shift
576  ie = ie + shift
577  do l=1,l_size
578  ptr_fieldx = f_addrsx(l, 1)
579  ptr_fieldy = f_addrsy(l, 1)
580  do k = 1,ke
581  do i = is,ie
582  fieldx(i,j,k) = -fieldx(i,j,k)
583  fieldy(i,j,k) = -fieldy(i,j,k)
584  end do
585  end do
586  end do
587  case(CGRID_NE)
588  do l=1,l_size
589  ptr_fieldy = f_addrsy(l, 1)
590  do k = 1,ke
591  do i = is, ie
592  fieldy(i,j,k) = -fieldy(i,j,k)
593  end do
594  end do
595  end do
596  end select
597  end if
598  end if
599  else if( BTEST(domain%fold,WEST) .AND. (.NOT.BTEST(update_flags,SCALAR_BIT)) )then ! ---eastern boundary fold
600  ! NOTE: symmetry is assumed for fold-west boundary
601  i = domain%x(1)%global%begin
602  if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain
603  midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2
604  !poles set to 0: BGRID only
605  if( gridtype.EQ.BGRID_NE )then
606  i = domain%x(1)%global%begin
607  js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift
608  do j = js ,je, midpoint
609  if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then
610  do l=1,l_size
611  ptr_fieldx = f_addrsx(l, 1)
612  ptr_fieldy = f_addrsy(l, 1)
613  do k = 1,ke
614  fieldx(i,j,k) = 0.
615  fieldy(i,j,k) = 0.
616  end do
617  end do
618  end if
619  end do
620  endif
621 
622  ! the following code code block correct an error where the data in your halo coming from
623  ! other half may have the wrong sign
624  !off south edge, when update south or west direction
625  i = domain%x(1)%global%begin
626  if ( recv(3) .OR. recv(5) ) then
627  select case(gridtype)
628  case(BGRID_NE)
629  js = domain%y(1)%global%begin
630  if( js.GT.domain%y(1)%data%begin )then
631 
632  if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) &
633  call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-west BGRID_NE west edge ubound error.' )
634  do l=1,l_size
635  ptr_fieldx = f_addrsx(l, 1)
636  ptr_fieldy = f_addrsy(l, 1)
637  do k = 1,ke
638  do j = domain%y(1)%data%begin,js-1
639  fieldx(i,2*js-j,k) = fieldx(i,2*js-j,k) + fieldx(i,j,k)
640  fieldy(i,2*js-j,k) = fieldy(i,2*js-j,k) + fieldy(i,j,k)
641  end do
642  end do
643  end do
644  end if
645  case(CGRID_NE)
646  js = domain%y(1)%global%begin
647  if( js.GT.domain%y(1)%data%begin )then
648  if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) &
649  call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-west CGRID_NE west edge ubound error.' )
650  do l=1,l_size
651  ptr_fieldx = f_addrsx(l, 1)
652  do k = 1,ke
653  do j = domain%y(1)%data%begin,js-1
654  fieldx(i, 2*js-j-1,k) = fieldx(i, 2*js-j-1,k) + fieldx(i,j,k)
655  end do
656  end do
657  end do
658  end if
659  end select
660  end if
661 
662  !off north edge
663  js = domain%y(1)%global%end
664  if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then
665  je = domain%y(1)%data%end
666  js = js + 1
667  select case(gridtype)
668  case(BGRID_NE)
669  js = js + shift
670  je = je + shift
671  do l=1,l_size
672  ptr_fieldx = f_addrsx(l, 1)
673  ptr_fieldy = f_addrsy(l, 1)
674  do k = 1,ke
675  do j = js,je
676  fieldx(i,j,k) = -fieldx(i,j,k)
677  fieldy(i,j,k) = -fieldy(i,j,k)
678  end do
679  end do
680  end do
681  case(CGRID_NE)
682  do l=1,l_size
683  ptr_fieldx = f_addrsx(l, 1)
684  do k = 1,ke
685  do j = js, je
686  fieldx(i,j,k) = -fieldx(i,j,k)
687  end do
688  end do
689  end do
690  end select
691  end if
692  end if
693  else if( BTEST(domain%fold,EAST) .AND. (.NOT.BTEST(update_flags,SCALAR_BIT)) )then ! ---eastern boundary fold
694  ! NOTE: symmetry is assumed for fold-west boundary
695  i = domain%x(1)%global%end+shift
696  if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain
697  midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2
698  !poles set to 0: BGRID only
699  if( gridtype.EQ.BGRID_NE )then
700  i = domain%x(1)%global%end+shift
701  js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift
702  do j = js ,je, midpoint
703  if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then
704  do l=1,l_size
705  ptr_fieldx = f_addrsx(l, 1)
706  ptr_fieldy = f_addrsy(l, 1)
707  do k = 1,ke
708  fieldx(i,j,k) = 0.
709  fieldy(i,j,k) = 0.
710  end do
711  end do
712  end if
713  end do
714  endif
715 
716  ! the following code code block correct an error where the data in your halo coming from
717  ! other half may have the wrong sign
718  !off south edge, when update south or west direction
719  i = domain%x(1)%global%end+shift
720  if ( recv(3) .OR. recv(1) ) then
721  select case(gridtype)
722  case(BGRID_NE)
723  js = domain%y(1)%global%begin
724  if( js.GT.domain%y(1)%data%begin )then
725 
726  if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) &
727  call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-east BGRID_NE west edge ubound error.' )
728  do l=1,l_size
729  ptr_fieldx = f_addrsx(l, 1)
730  ptr_fieldy = f_addrsy(l, 1)
731  do k = 1,ke
732  do j = domain%y(1)%data%begin,js-1
733  fieldx(i,2*js-j,k) = fieldx(i,2*js-j,k) + fieldx(i,j,k)
734  fieldy(i,2*js-j,k) = fieldy(i,2*js-j,k) + fieldy(i,j,k)
735  end do
736  end do
737  end do
738  end if
739  case(CGRID_NE)
740  js = domain%y(1)%global%begin
741  if( js.GT.domain%y(1)%data%begin )then
742  if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) &
743  call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-east CGRID_NE west edge ubound error.' )
744  do l=1,l_size
745  ptr_fieldx = f_addrsx(l, 1)
746  do k = 1,ke
747  do j = domain%y(1)%data%begin,js-1
748  fieldx(i, 2*js-j-1,k) = fieldx(i, 2*js-j-1,k) + fieldx(i,j,k)
749  end do
750  end do
751  end do
752  end if
753  end select
754  end if
755 
756  !off north edge
757  js = domain%y(1)%global%end
758  if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then
759  je = domain%y(1)%data%end
760  js = js + 1
761  select case(gridtype)
762  case(BGRID_NE)
763  js = js + shift
764  je = je + shift
765  do l=1,l_size
766  ptr_fieldx = f_addrsx(l, 1)
767  ptr_fieldy = f_addrsy(l, 1)
768  do k = 1,ke
769  do j = js,je
770  fieldx(i,j,k) = -fieldx(i,j,k)
771  fieldy(i,j,k) = -fieldy(i,j,k)
772  end do
773  end do
774  end do
775  case(CGRID_NE)
776  do l=1,l_size
777  ptr_fieldx = f_addrsx(l, 1)
778  do k = 1,ke
779  do j = js, je
780  fieldx(i,j,k) = -fieldx(i,j,k)
781  end do
782  end do
783  end do
784  end select
785  end if
786  end if
787  end if
788 !unpacking done
789 
790  !--- recv
791  buffer_pos = 0
792  cur_rank = get_rank_recv(domain, update_x, update_y, rank_x, rank_y, ind_x, ind_y)
793 
794  do while (ind_x .LE. nrecv_x .OR. ind_y .LE. nrecv_y)
795  msgsize = 0
796  select case(gridtype)
797  case(BGRID_NE, BGRID_SW, AGRID)
798  if(cur_rank == rank_x) then
799  from_pe = update_x%recv(ind_x)%pe
800  do n = 1, update_x%recv(ind_x)%count
801  dir = update_x%recv(ind_x)%dir(n)
802  if(recv(dir)) then
803  tMe = update_x%recv(ind_x)%tileMe(n)
804  is = update_x%recv(ind_x)%is(n); ie = update_x%recv(ind_x)%ie(n)
805  js = update_x%recv(ind_x)%js(n); je = update_x%recv(ind_x)%je(n)
806  msgsize = msgsize + (ie-is+1)*(je-js+1)
807  end if
808  end do
809  msgsize = msgsize*2
810  ind_x = ind_x+1
811  ind_y = ind_x
812  if(ind_x .LE. nrecv_x) then
813  rank_x = update_x%recv(ind_x)%pe - domain%pe
814  if(rank_x .LE.0) rank_x = rank_x + nlist
815  else
816  rank_x = -1
817  endif
818  rank_y = rank_x
819  endif
820  case(CGRID_NE, CGRID_SW)
821  if(cur_rank == rank_x) then
822  from_pe = update_x%recv(ind_x)%pe
823  do n = 1, update_x%recv(ind_x)%count
824  dir = update_x%recv(ind_x)%dir(n)
825  if(recv(dir)) then
826  is = update_x%recv(ind_x)%is(n); ie = update_x%recv(ind_x)%ie(n)
827  js = update_x%recv(ind_x)%js(n); je = update_x%recv(ind_x)%je(n)
828  msgsize = msgsize + (ie-is+1)*(je-js+1)
829  end if
830  end do
831  ind_x = ind_x+1
832  if(ind_x .LE. nrecv_x) then
833  rank_x = update_x%recv(ind_x)%pe - domain%pe
834  if(rank_x .LE.0) rank_x = rank_x + nlist
835  else
836  rank_x = -1
837  endif
838  endif
839  if(cur_rank == rank_y) then
840  from_pe = update_y%recv(ind_y)%pe
841  do n = 1, update_y%recv(ind_y)%count
842  dir = update_y%recv(ind_y)%dir(n)
843  if(recv(dir)) then
844  is = update_y%recv(ind_y)%is(n); ie = update_y%recv(ind_y)%ie(n)
845  js = update_y%recv(ind_y)%js(n); je = update_y%recv(ind_y)%je(n)
846  msgsize = msgsize + (ie-is+1)*(je-js+1)
847  end if
848  end do
849  ind_y = ind_y+1
850  if(ind_y .LE. nrecv_y) then
851  rank_y = update_y%recv(ind_y)%pe - domain%pe
852  if(rank_y .LE.0) rank_y = rank_y + nlist
853  else
854  rank_y = -1
855  endif
856  endif
857  end select
858  cur_rank = max(rank_x, rank_y)
859  msgsize = msgsize*ke*l_size
860 
861  if( msgsize.GT.0 )then
862  call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=from_pe, tag=COMM_TAG_2 )
863  buffer_pos = buffer_pos + msgsize
864  end if
865  end do
866  buffer_recv_size = buffer_pos
867  cur_rank = get_rank_send(domain, update_x, update_y, rank_x, rank_y, ind_x, ind_y)
868 
869  do while (ind_x .LE. nsend_x .OR. ind_y .LE. nsend_y)
870  pos = buffer_pos
871  !--- make sure the domain stack size is big enough
872  msgsize = 0
873 
874  if(cur_rank == rank_x) then
875  to_pe = update_x%send(ind_x)%pe
876  do n = 1, update_x%send(ind_x)%count
877  dir = update_x%send(ind_x)%dir(n)
878  if( send(dir) ) msgsize = msgsize + update_x%send(ind_x)%msgsize(n)
879  enddo
880  endif
881  if(cur_rank == rank_y) then
882  to_pe = update_y%send(ind_y)%pe
883  do n = 1, update_y%send(ind_y)%count
884  dir = update_y%send(ind_y)%dir(n)
885  if( send(dir) ) msgsize = msgsize + update_y%send(ind_y)%msgsize(n)
886  enddo
887  endif
888 
889  select case( gridtype )
890  case(BGRID_NE, BGRID_SW, AGRID)
891  if(cur_rank == rank_x) then
892  to_pe = update_x%send(ind_x)%pe
893  ind_x = ind_x+1
894  ind_y = ind_x
895  if(ind_x .LE. nsend_x) then
896  rank_x = update_x%send(ind_x)%pe - domain%pe
897  if(rank_x .LT.0) rank_x = rank_x + nlist
898  else
899  rank_x = nlist+1
900  endif
901  rank_y = rank_x
902  endif
903  case(CGRID_NE, CGRID_SW)
904  if(cur_rank == rank_x) then
905  to_pe = update_x%send(ind_x)%pe
906  ind_x = ind_x+1
907  if(ind_x .LE. nsend_x) then
908  rank_x = update_x%send(ind_x)%pe - domain%pe
909  if(rank_x .LT.0) rank_x = rank_x + nlist
910  else
911  rank_x = nlist+1
912  endif
913  endif
914  if(cur_rank == rank_y) then
915  to_pe = update_y%send(ind_y)%pe
916  ind_y = ind_y+1
917  if(ind_y .LE. nsend_y) then
918  rank_y = update_y%send(ind_y)%pe - domain%pe
919  if(rank_y .LT.0) rank_y = rank_y + nlist
920  else
921  rank_y = nlist+1
922  endif
923  endif
924  end select
925  cur_rank = min(rank_x, rank_y)
926 
927  if( msgsize.GT.0 )then
928  msgsize = msgsize*ke*l_size
929  end if
930 
931  if( msgsize.GT.0 )then
932  call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=to_pe, block=.false., tag=COMM_TAG_2 )
933  buffer_pos = buffer_pos + msgsize
934  end if
935 
936  enddo
937 
938  call mpp_sync_self(check=EVENT_RECV)
939 
940  !--- send
941  buffer_pos = buffer_recv_size
942  pos = buffer_pos
943 
944  cur_rank = get_rank_send(domain, update_x, update_y, rank_x, rank_y, ind_x, ind_y)
945 
946  do while (ind_x .LE. nsend_x .OR. ind_y .LE. nsend_y)
947  pos = buffer_pos
948  select case( gridtype )
949  case(BGRID_NE, BGRID_SW, AGRID)
950  if(cur_rank == rank_x) then
951  to_pe = update_x%send(ind_x)%pe
952  do n = 1, update_x%send(ind_x)%count
953  dir = update_x%send(ind_x)%dir(n)
954  if( send(dir) ) then
955  tMe = update_x%send(ind_x)%tileMe(n)
956 
957  is = update_x%send(ind_x)%is(n); ie = update_x%send(ind_x)%ie(n)
958  js = update_x%send(ind_x)%js(n); je = update_x%send(ind_x)%je(n)
959 
960  select case( update_x%send(ind_x)%rotation(n) )
961  case(ZERO)
962  do l=1,l_size ! loop over number of fields
963  ptr_fieldx = f_addrsx(l,tMe)
964  ptr_fieldy = f_addrsy(l,tMe)
965  do k = 1,ke
966  do j = js, je
967  do i = is, ie
968  pos = pos + 2
969  fieldx(i,j,k)=fieldx(i,j,k)+buffer(pos-1)
970  fieldy(i,j,k)=fieldy(i,j,k)+buffer(pos)
971  end do
972  end do
973  end do
974  end do
975  case( MINUS_NINETY )
976  if( BTEST(update_flags,SCALAR_BIT) ) then
977  do l=1,l_size ! loop over number of fields
978  ptr_fieldx = f_addrsx(l,tMe)
979  ptr_fieldy = f_addrsy(l,tMe)
980  do k = 1,ke
981  do i = is, ie
982  do j = je, js, -1
983  pos = pos + 2
984  fieldy(i,j,k)=fieldy(i,j,k)+buffer(pos-1)
985  fieldx(i,j,k)=fieldx(i,j,k)+buffer(pos)
986  end do
987  end do
988  end do
989  end do
990  else
991  do l=1,l_size ! loop over number of fields
992  ptr_fieldx = f_addrsx(l,tMe)
993  ptr_fieldy = f_addrsy(l,tMe)
994  do k = 1,ke
995  do i = is, ie
996  do j = je, js, -1
997  pos = pos + 2
998  fieldy(i,j,k)=fieldy(i,j,k)-buffer(pos-1)
999  fieldx(i,j,k)=fieldx(i,j,k)+buffer(pos)
1000  end do
1001  end do
1002  end do
1003  end do
1004  end if
1005  case( NINETY )
1006  if( BTEST(update_flags,SCALAR_BIT) ) then
1007  do l=1,l_size ! loop over number of fields
1008  ptr_fieldx = f_addrsx(l,tMe)
1009  ptr_fieldy = f_addrsy(l,tMe)
1010  do k = 1,ke
1011  do i = ie, is, -1
1012  do j = js, je
1013  pos = pos + 2
1014  fieldy(i,j,k)=fieldy(i,j,k)+buffer(pos-1)
1015  fieldx(i,j,k)=fieldx(i,j,k)+buffer(pos)
1016  end do
1017  end do
1018  end do
1019  end do
1020  else
1021  do l=1,l_size ! loop over number of fields
1022  ptr_fieldx = f_addrsx(l,tMe)
1023  ptr_fieldy = f_addrsy(l,tMe)
1024  do k = 1,ke
1025  do i = ie, is, -1
1026  do j = js, je
1027  pos = pos + 2
1028  fieldy(i,j,k)=fieldy(i,j,k)+buffer(pos-1)
1029  fieldx(i,j,k)=fieldx(i,j,k)-buffer(pos)
1030  end do
1031  end do
1032  end do
1033  end do
1034  end if
1035  case( ONE_HUNDRED_EIGHTY )
1036  if( BTEST(update_flags,SCALAR_BIT) ) then
1037  do l=1,l_size ! loop over number of fields
1038  ptr_fieldx = f_addrsx(l,tMe)
1039  ptr_fieldy = f_addrsy(l,tMe)
1040  do k = 1,ke
1041  do j = je, js, -1
1042  do i = ie, is, -1
1043  pos = pos + 2
1044  fieldx(i,j,k)=fieldx(i,j,k)+buffer(pos-1)
1045  fieldy(i,j,k)=fieldy(i,j,k)+buffer(pos)
1046  end do
1047  end do
1048  end do
1049  end do
1050  else
1051  do l=1,l_size ! loop over number of fields
1052  ptr_fieldx = f_addrsx(l,tMe)
1053  ptr_fieldy = f_addrsy(l,tMe)
1054  do k = 1,ke
1055  do j = je, js, -1
1056  do i = ie, is, -1
1057  pos = pos + 2
1058  fieldx(i,j,k)=fieldx(i,j,k)-buffer(pos-1)
1059  fieldy(i,j,k)=fieldy(i,j,k)-buffer(pos)
1060  end do
1061  end do
1062  end do
1063  end do
1064  end if
1065  end select ! select case( rotation(n) )
1066  end if ! if( send(dir) )
1067  end do ! do n = 1, update_x%send(ind_x)%count
1068  ind_x = ind_x+1
1069  ind_y = ind_x
1070  if(ind_x .LE. nsend_x) then
1071  rank_x = update_x%send(ind_x)%pe - domain%pe
1072  if(rank_x .LT.0) rank_x = rank_x + nlist
1073  else
1074  rank_x = nlist+1
1075  endif
1076  rank_y = rank_x
1077  endif
1078  case(CGRID_NE, CGRID_SW)
1079  if(cur_rank == rank_x) then
1080  to_pe = update_x%send(ind_x)%pe
1081  do n = 1, update_x%send(ind_x)%count
1082  dir = update_x%send(ind_x)%dir(n)
1083  if( send(dir) ) then
1084  tMe = update_x%send(ind_x)%tileMe(n)
1085  is = update_x%send(ind_x)%is(n); ie = update_x%send(ind_x)%ie(n)
1086  js = update_x%send(ind_x)%js(n); je = update_x%send(ind_x)%je(n)
1087  select case( update_x%send(ind_x)%rotation(n) )
1088  case(ZERO)
1089  do l=1,l_size ! loop over number of fields
1090  ptr_fieldx = f_addrsx(l, tMe)
1091  ptr_fieldy = f_addrsy(l, tMe)
1092  do k = 1,ke
1093  do j = js, je
1094  do i = is, ie
1095  pos = pos + 1
1096  fieldx(i,j,k)=fieldx(i,j,k)+buffer(pos)
1097  end do
1098  end do
1099  end do
1100  end do
1101  case(MINUS_NINETY)
1102  if( BTEST(update_flags,SCALAR_BIT) ) then
1103  do l=1,l_size ! loop over number of fields
1104  ptr_fieldx = f_addrsx(l, tMe)
1105  ptr_fieldy = f_addrsy(l, tMe)
1106  do k = 1,ke
1107  do i = is, ie
1108  do j = je, js, -1
1109  pos = pos + 1
1110  fieldy(i,j,k)=fieldy(i,j,k)+buffer(pos)
1111  end do
1112  end do
1113  end do
1114  end do
1115  else
1116  do l=1,l_size ! loop over number of fields
1117  ptr_fieldx = f_addrsx(l, tMe)
1118  ptr_fieldy = f_addrsy(l, tMe)
1119  do k = 1,ke
1120  do i = is, ie
1121  do j = je, js, -1
1122  pos = pos + 1
1123  fieldy(i,j,k)=fieldy(i,j,k)-buffer(pos)
1124  end do
1125  end do
1126  end do
1127  end do
1128  end if
1129  case(NINETY)
1130  do l=1,l_size ! loop over number of fields
1131  ptr_fieldx = f_addrsx(l, tMe)
1132  ptr_fieldy = f_addrsy(l, tMe)
1133  do k = 1, ke
1134  do i = ie, is, -1
1135  do j = js, je
1136  pos = pos + 1
1137  fieldy(i,j,k)=fieldy(i,j,k)+buffer(pos)
1138  end do
1139  end do
1140  end do
1141  end do
1142  case(ONE_HUNDRED_EIGHTY)
1143  if( BTEST(update_flags,SCALAR_BIT) ) then
1144  do l=1,l_size ! loop over number of fields
1145  ptr_fieldx = f_addrsx(l, tMe)
1146  ptr_fieldy = f_addrsy(l, tMe)
1147  do k = 1,ke
1148  do j = je, js, -1
1149  do i = ie, is, -1
1150  pos = pos + 1
1151  fieldx(i,j,k)=fieldx(i,j,k)+buffer(pos)
1152  end do
1153  end do
1154  end do
1155  end do
1156  else
1157  do l=1,l_size ! loop over number of fields
1158  ptr_fieldx = f_addrsx(l, tMe)
1159  ptr_fieldy = f_addrsy(l, tMe)
1160  do k = 1,ke
1161  do j = je, js, -1
1162  do i = ie, is, -1
1163  pos = pos + 1
1164  fieldx(i,j,k)=fieldx(i,j,k)-buffer(pos)
1165  end do
1166  end do
1167  end do
1168  end do
1169  end if
1170  end select
1171  end if
1172  end do
1173  ind_x = ind_x+1
1174  if(ind_x .LE. nsend_x) then
1175  rank_x = update_x%send(ind_x)%pe - domain%pe
1176  if(rank_x .LT.0) rank_x = rank_x + nlist
1177  else
1178  rank_x = nlist+1
1179  endif
1180  endif
1181  if(cur_rank == rank_y) then
1182  to_pe = update_y%send(ind_y)%pe
1183  do n = 1, update_y%send(ind_y)%count
1184  dir = update_y%send(ind_y)%dir(n)
1185  if( send(dir) ) then
1186  tMe = update_y%send(ind_y)%tileMe(n)
1187  is = update_y%send(ind_y)%is(n); ie = update_y%send(ind_y)%ie(n)
1188  js = update_y%send(ind_y)%js(n); je = update_y%send(ind_y)%je(n)
1189 
1190  select case( update_y%send(ind_y)%rotation(n) )
1191  case(ZERO)
1192  do l=1,l_size ! loop over number of fields
1193  ptr_fieldx = f_addrsx(l, tMe)
1194  ptr_fieldy = f_addrsy(l, tMe)
1195  do k = 1,ke
1196  do j = js, je
1197  do i = is, ie
1198  pos = pos + 1
1199  fieldy(i,j,k)=fieldy(i,j,k)+buffer(pos)
1200  end do
1201  end do
1202  end do
1203  end do
1204  case(MINUS_NINETY)
1205  do l=1,l_size ! loop over number of fields
1206  ptr_fieldx = f_addrsx(l, tMe)
1207  ptr_fieldy = f_addrsy(l, tMe)
1208  do k = 1,ke
1209  do i = is, ie
1210  do j = je, js, -1
1211  pos = pos + 1
1212  fieldx(i,j,k)=fieldx(i,j,k)+buffer(pos)
1213  end do
1214  end do
1215  end do
1216  end do
1217  case(NINETY)
1218  if( BTEST(update_flags,SCALAR_BIT) ) then
1219  do l=1,l_size ! loop over number of fields
1220  ptr_fieldx = f_addrsx(l, tMe)
1221  ptr_fieldy = f_addrsy(l, tMe)
1222  do k = 1,ke
1223  do i = ie, is, -1
1224  do j = js, je
1225  pos = pos + 1
1226  fieldx(i,j,k)=fieldx(i,j,k)+buffer(pos)
1227  end do
1228  end do
1229  end do
1230  end do
1231  else
1232  do l=1,l_size ! loop over number of fields
1233  ptr_fieldx = f_addrsx(l, tMe)
1234  ptr_fieldy = f_addrsy(l, tMe)
1235  do k = 1,ke
1236  do i = ie, is, -1
1237  do j = js, je
1238  pos = pos + 1
1239  fieldx(i,j,k)=fieldx(i,j,k)-buffer(pos)
1240  end do
1241  end do
1242  end do
1243  end do
1244  end if
1245  case(ONE_HUNDRED_EIGHTY)
1246  if( BTEST(update_flags,SCALAR_BIT) ) then
1247  do l=1,l_size ! loop over number of fields
1248  ptr_fieldx = f_addrsx(l, tMe)
1249  ptr_fieldy = f_addrsy(l, tMe)
1250  do k = 1,ke
1251  do j = je, js, -1
1252  do i = ie, is, -1
1253  pos = pos + 1
1254  fieldy(i,j,k)=fieldy(i,j,k)+buffer(pos)
1255  end do
1256  end do
1257  end do
1258  end do
1259  else
1260  do l=1,l_size ! loop over number of fields
1261  ptr_fieldx = f_addrsx(l, tMe)
1262  ptr_fieldy = f_addrsy(l, tMe)
1263  do k = 1,ke
1264  do j = je, js, -1
1265  do i = ie, is, -1
1266  pos = pos + 1
1267  fieldy(i,j,k)=fieldy(i,j,k)-buffer(pos)
1268  end do
1269  end do
1270  end do
1271  end do
1272  end if
1273  end select
1274  endif
1275  enddo
1276  ind_y = ind_y+1
1277  if(ind_y .LE. nsend_y) then
1278  rank_y = update_y%send(ind_y)%pe - domain%pe
1279  if(rank_y .LT.0) rank_y = rank_y + nlist
1280  else
1281  rank_y = nlist+1
1282  endif
1283  endif
1284  end select
1285  cur_rank = min(rank_x, rank_y)
1286  msgsize = pos - buffer_pos
1287  if( msgsize.GT.0 )then
1288  buffer_pos = pos
1289  end if
1290  end do
1291 
1292  call mpp_sync_self( )
1293 
1294  return
1295 
1296  end subroutine MPP_DO_UPDATE_AD_3D_V_
nesdis_landem_module::half
real(fp), parameter, public half
Definition: NESDIS_LandEM_Module.f90:63
will
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version will
Definition: mpp_transmit_mpi.h:166
time_interp_external_mod::field
type(ext_fieldtype), dimension(:), pointer, save, private field
Definition: time_interp_external.F90:137
integer
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_ ::wbuffer3D(size(wbuffer, 1), size(wbuffer, 2), 1) MPP_TYPE_ ::ebuffer3D(size(ebuffer, 1), size(ebuffer, 2), 1) MPP_TYPE_ ::sbuffer3D(size(sbuffer, 1), size(sbuffer, 2), 1) MPP_TYPE_ ::nbuffer3D(size(nbuffer, 1), size(nbuffer, 2), 1) pointer(ptr, field3D) pointer(ptr_w, wbuffer3D) pointer(ptr_e, ebuffer3D) pointer(ptr_s, sbuffer3D) pointer(ptr_n, nbuffer3D) ptr=LOC(field) ptr_w=LOC(wbuffer) ptr_e=LOC(ebuffer) ptr_s=LOC(sbuffer) ptr_n=LOC(nbuffer) call mpp_update_nest_fine(field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, &flags, complete, position, extra_halo, name, tile_count) returnend subroutine MPP_UPDATE_NEST_FINE_2D_subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::d_type type(nestSpec), pointer ::update=> set_mismatch integer ::tile update_position nbuffersz l_size integer
Definition: mpp_update_nest_domains.h:79
i
l_size ! loop over number of fields ke do je do i
Definition: mpp_do_redistribute.h:71
fms_io_mod::je
integer, private je
Definition: fms_io.F90:494
crtm_lowfrequency_mwssem::n
integer n
Definition: CRTM_LowFrequency_MWSSEM.f90:172
not
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If not
Definition: mpp_do_updateV_ad.h:7
mpp_parameter_mod::recv
integer, parameter recv
Definition: mpp_parameter.F90:99
allocatable
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_WRITE_UNLIMITED_AXIS_1D_(unit, field, domain, data, nelems_io) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:) integer, intent(in) ::nelems_io(:) ! number of compressed elements from each ! member of the io_domain. It MUST have the ! same order as the io_domain pelist. integer, allocatable ::pelist(:) integer ::i, j, nelems, npes type(domain2d), pointer ::io_domain=> allocatable
Definition: mpp_write_unlimited_axis.h:30
fv3jedi_increment_mod::copy
subroutine, public copy(self, rhs)
Definition: fv3jedi_increment_mod.f90:254
end
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT end
Definition: mpp_transmit_mpi.h:153
cloudcoeff_define::set
integer, parameter set
Definition: CloudCoeff_Define.f90:63
mpp_io_mod::text
character(len=256) text
Definition: mpp_io.F90:1051
binary_file_utility::true
integer(long), parameter true
Definition: Binary_File_Utility.f90:61
field_manager_mod::fields
type(field_mgr_type), dimension(max_fields), private fields
Definition: field_manager.F90:536
binary_file_utility::false
integer(long), parameter false
Definition: Binary_File_Utility.f90:60
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
interpolator_mod::name
character(len=32) name
Definition: interpolator.F90:329
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
to_pe
l_size ! loop over number of fields ke do je do ie to to_pe
Definition: mpp_do_redistribute.h:72
time_interp_external_mod::outunit
integer outunit
Definition: time_interp_external.F90:135
mersennetwister_mod::m
integer, parameter m
Definition: MersenneTwister.F90:79
ensemble_manager_mod::pe
integer pe
Definition: ensemble_manager.F90:50
diag_integral_mod::version
character(len=128) version
Definition: diag_integral.F90:121
is
l_size ! loop over number of fields ke do je do ie to is
Definition: mpp_do_redistribute.h:72
c2f.type
type
Definition: c2f.py:15
mpp_parameter_mod::global
integer, parameter, public global
Definition: mpp_parameter.F90:94
fms_io_mod::ie
integer, private ie
Definition: fms_io.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
mpp_mod::error
integer error
Definition: mpp.F90:1310
gsw_mod_sp_coefficients::k
real(r8), parameter k
Definition: gsw_mod_sp_coefficients.f90:40
msgsize
l_size ! loop over number of fields ke do je do ie to je msgsize
Definition: mpp_do_redistribute.h:79
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_parameter_mod::east
integer, parameter, public east
Definition: mpp_parameter.F90:95
type_distribution::received
logical function received(this, seqno)
Definition: m_distribution.f90:72
fv3jedi_increment_mod::check
subroutine check(self)
Definition: fv3jedi_increment_mod.f90:1932
mpp_domains_mod::debug_message_passing
logical debug_message_passing
Definition: mpp_domains.F90:702
interpolator_mod::len
integer len
Definition: interpolator.F90:321
LONG_KIND
#define LONG_KIND
update_flags
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_ ::wbuffer3D(size(wbuffer, 1), size(wbuffer, 2), 1) MPP_TYPE_ ::ebuffer3D(size(ebuffer, 1), size(ebuffer, 2), 1) MPP_TYPE_ ::sbuffer3D(size(sbuffer, 1), size(sbuffer, 2), 1) MPP_TYPE_ ::nbuffer3D(size(nbuffer, 1), size(nbuffer, 2), 1) pointer(ptr, field3D) pointer(ptr_w, wbuffer3D) pointer(ptr_e, ebuffer3D) pointer(ptr_s, sbuffer3D) pointer(ptr_n, nbuffer3D) ptr=LOC(field) ptr_w=LOC(wbuffer) ptr_e=LOC(ebuffer) ptr_s=LOC(sbuffer) ptr_n=LOC(nbuffer) call mpp_update_nest_fine(field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, &flags, complete, position, extra_halo, name, tile_count) returnend subroutine MPP_UPDATE_NEST_FINE_2D_subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::d_type type(nestSpec), pointer ::update=> set_mismatch integer ::tile update_flags
Definition: mpp_update_nest_domains.h:79
size
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this ! since that attempts to gather all data on PE size(field%axes(:)) axsiz(i)
mpp_parameter_mod::north
integer, parameter, public north
Definition: mpp_parameter.F90:95
a
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version and mpp_transmit will remain !backward compatible intent(inout) a
Definition: mpp_transmit_mpi.h:178
max
#define max(a, b)
Definition: mosaic_util.h:33
mpp_parameter_mod::cyclic
integer, parameter, public cyclic
Definition: mpp_parameter.F90:94
pos
l_size ! loop over number of fields ke do je do ie pos
Definition: mpp_do_redistribute.h:72
min
#define min(a, b)
Definition: mosaic_util.h:32
mpp_parameter_mod::south
integer, parameter, public south
Definition: mpp_parameter.F90:95
js
l_size ! loop over number of fields ke do je do ie to js
Definition: mpp_do_redistribute.h:72
begin
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version and mpp_transmit will remain !backward compatible intent(inout) MPP_BROADCAST begin
Definition: mpp_transmit_mpi.h:179