FV3 Bundle
mpp_do_get_boundary_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_GET_BOUNDARY_AD_3D_( f_addrs, domain, bound, b_addrs, bsize, ke, d_type)
24  type(domain2D), intent(in) :: domain
25  type(overlapSpec), intent(in) :: bound
26  integer(LONG_KIND), intent(in) :: f_addrs(:,:)
27  integer(LONG_KIND), intent(in) :: b_addrs(:,:,:)
28  integer, intent(in) :: bsize(:), ke
29  MPP_TYPE_, intent(in) :: d_type ! creates unique interface
30 
31  MPP_TYPE_ :: field(bound%xbegin:bound%xend, bound%ybegin:bound%yend,ke)
32  MPP_TYPE_ :: ebuffer(bsize(1), ke), sbuffer(bsize(2), ke), wbuffer(bsize(3), ke), nbuffer(bsize(4), ke)
33  pointer(ptr_field, field)
34  pointer(ptr_ebuffer, ebuffer)
35  pointer(ptr_sbuffer, sbuffer)
36  pointer(ptr_wbuffer, wbuffer)
37  pointer(ptr_nbuffer, nbuffer)
38 
39  integer, allocatable :: msg1(:), msg2(:)
40  logical :: recv(4), send(4)
41  integer :: nlist, buffer_pos, pos, tMe, from_pe
42  integer :: i, j, k, l, m, n, index, buffer_recv_size
43  integer :: is, ie, js, je, msgsize, l_size, num
44  character(len=8) :: text
45  integer :: outunit
46 
47  MPP_TYPE_ :: buffer(size(mpp_domains_stack(:)))
48 
49  pointer( ptr, buffer )
50  ptr = LOC(mpp_domains_stack)
51 
52  outunit = stdout()
53  l_size = size(f_addrs,1)
54 
55  !---- determine recv(1) based on b_addrs ( east boundary )
56  num = count(b_addrs(1,:,1) == 0)
57  if( num == 0 ) then
58  recv(1) = .true.
59  else if( num == l_size ) then
60  recv(1) = .false.
61  else
62  if( num .NE. 0 ) call mpp_error(FATAL, &
63  "mpp_do_get_boundary: number of ebuffer with null address should be 0 or l_size")
64  endif
65 
66  !---- determine recv(2) based on b_addrs ( south boundary )
67  num = count(b_addrs(2,:,1) == 0)
68  if( num == 0 ) then
69  recv(2) = .true.
70  else if( num == l_size ) then
71  recv(2) = .false.
72  else
73  if( num .NE. 0 ) call mpp_error(FATAL, &
74  "mpp_do_get_boundary: number of sbuffer with null address should be 0 or l_size")
75  endif
76 
77  !---- determine recv(3) based on b_addrs ( west boundary )
78  num = count(b_addrs(3,:,1) == 0)
79  if( num == 0 ) then
80  recv(3) = .true.
81  else if( num == l_size ) then
82  recv(3) = .false.
83  else
84  if( num .NE. 0 ) call mpp_error(FATAL, &
85  "mpp_do_get_boundary: number of wbuffer with null address should be 0 or l_size")
86  endif
87 
88  !---- determine recv(4) based on b_addrs ( north boundary )
89  num = count(b_addrs(4,:,1) == 0)
90  if( num == 0 ) then
91  recv(4) = .true.
92  else if( num == l_size ) then
93  recv(4) = .false.
94  else
95  if( num .NE. 0 ) call mpp_error(FATAL, &
96  "mpp_do_get_boundary: number of nbuffer with null address should be 0 or l_size")
97  endif
98 
99  send = recv
100  nlist = size(domain%list(:))
101 
102  if(debug_message_passing) then
103  allocate(msg1(0:nlist-1), msg2(0:nlist-1) )
104  msg1 = 0
105  msg2 = 0
106 
107  do m = 1, bound%nrecv
108  msgsize = 0
109  do n = 1, bound%recv(m)%count
110  if(recv(bound%recv(m)%dir(n))) then
111  is = bound%recv(m)%is(n); ie = bound%recv(m)%ie(n)
112  js = bound%recv(m)%js(n); je = bound%recv(m)%je(n)
113  msgsize = msgsize + (ie-is+1)*(je-js+1)
114  end if
115  end do
116  from_pe = bound%recv(m)%pe
117  l = from_pe-mpp_root_pe()
118  call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_1)
119  msg2(l) = msgsize
120  enddo
121 
122  do m = 1, bound%nsend
123  msgsize = 0
124  do n = 1, bound%send(m)%count
125  if(recv(bound%send(m)%dir(n))) then
126  is = bound%send(m)%is(n); ie = bound%send(m)%ie(n)
127  js = bound%send(m)%js(n); je = bound%send(m)%je(n)
128  msgsize = msgsize + (ie-is+1)*(je-js+1)
129  end if
130  end do
131  call mpp_send( msgsize, plen=1, to_pe=bound%send(m)%pe, tag=COMM_TAG_1)
132  enddo
133 
134  call mpp_sync_self(check=EVENT_RECV)
135 
136  do m = 0, nlist-1
137  if(msg1(m) .NE. msg2(m)) then
138  print*, "My pe = ", mpp_pe(), ",domain name =", trim(domain%name), ",from pe=", &
139  domain%list(m)%pe, ":send size = ", msg1(m), ", recv size = ", msg2(m)
140  call mpp_error(FATAL, "mpp_do_get_boundary: mismatch on send and recv size")
141  endif
142  enddo
143  call mpp_sync_self()
144  write(outunit,*)"NOTE from mpp_do_get_boundary: message sizes are matched between send and recv for domain " &
145  //trim(domain%name)
146  deallocate(msg1, msg2)
147  endif
148  !recv
149  buffer_pos = 0
150  do m = 1, bound%nrecv
151  msgsize = 0
152  do n = 1, bound%recv(m)%count
153  if(recv(bound%recv(m)%dir(n))) then
154  is = bound%recv(m)%is(n); ie = bound%recv(m)%ie(n)
155  js = bound%recv(m)%js(n); je = bound%recv(m)%je(n)
156  msgsize = msgsize + (ie-is+1)*(je-js+1)
157  end if
158  end do
159  msgsize = msgsize*ke*l_size
160  if( msgsize.GT.0 )then
161  mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize) )
162  if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
163  write( text,'(i8)' )mpp_domains_stack_hwm
164  call mpp_error( FATAL, 'MPP_DO_GET_BOUNDARY_OLD: mpp_domains_stack overflow, '// &
165  'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.' )
166  end if
167  call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=bound%recv(m)%pe, block=.false., tag=COMM_TAG_2 )
168  buffer_pos = buffer_pos + msgsize
169  end if
170  end do
171  buffer_recv_size = buffer_pos
172 
173  ! send
174  do m = 1, bound%nsend
175  pos = buffer_pos
176  do n = 1, bound%send(m)%count
177  if(send(bound%send(m)%dir(n))) then
178  is = bound%send(m)%is(n); ie = bound%send(m)%ie(n)
179  js = bound%send(m)%js(n); je = bound%send(m)%je(n)
180  tMe = bound%send(m)%tileMe(n)
181  select case( bound%send(m)%rotation(n) )
182  case(ZERO)
183  do l=1,l_size
184  ptr_field = f_addrs(l, tMe)
185  do k = 1, ke
186  do j = js, je
187  do i = is, ie
188  pos = pos + 1
189  buffer(pos) = field(i,j,k)
190  end do
191  end do
192  end do
193  end do
194  case( MINUS_NINETY )
195  do l=1,l_size
196  ptr_field = f_addrs(l, tMe)
197  do k = 1, ke
198  do j = je, js, -1
199  do i = is, ie
200  pos = pos + 1
201  buffer(pos) = field(i,j,k)
202  end do
203  end do
204  end do
205  end do
206  case( NINETY )
207  do l=1,l_size
208  ptr_field = f_addrs(l, tMe)
209  do k = 1, ke
210  do j = js, je
211  do i = ie, is, -1
212  pos = pos + 1
213  buffer(pos) = field(i,j,k)
214  end do
215  end do
216  end do
217  end do
218  case (ONE_HUNDRED_EIGHTY)
219  do l=1,l_size
220  ptr_field = f_addrs(l, tMe)
221  do k = 1, ke
222  do j = je, js, -1
223  do i = ie, is, -1
224  pos = pos + 1
225  buffer(pos) = field(i,j,k)
226  end do
227  end do
228  end do
229  end do
230  end select
231  end if ! if(send(bound%dir(n)))
232  end do ! do n = 1, bound%count
233  msgsize = pos - buffer_pos
234  if( msgsize.GT.0 )then
235  !--- maybe we do not need the following stack size check.
236  mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos )
237  if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
238  write( text,'(i8)' )mpp_domains_stack_hwm
239  call mpp_error( FATAL, 'MPP_DO_GET_BOUNDARY_OLD: mpp_domains_stack overflow, ' // &
240  'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.')
241  end if
242  call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=bound%send(m)%pe, tag=COMM_TAG_2 )
243  buffer_pos = pos
244  end if
245  end do
246 
247  call mpp_clock_begin(wait_clock)
248  call mpp_sync_self(check=EVENT_RECV)
249  call mpp_clock_end(wait_clock)
250  buffer_pos = buffer_recv_size
251 
252  !unpack recv
253  !unpack buffer in reverse order.
254  do m = bound%nrecv, 1, -1
255  do n = bound%recv(m)%count, 1, -1
256  if(recv(bound%recv(m)%dir(n))) then
257  is = bound%recv(m)%is(n); ie = bound%recv(m)%ie(n)
258  js = bound%recv(m)%js(n); je = bound%recv(m)%je(n)
259  msgsize = (ie-is+1)*(je-js+1)*ke*l_size
260  pos = buffer_pos - msgsize
261  buffer_pos = pos
262  tMe = bound%recv(m)%tileMe(n)
263  select case( bound%recv(m)%dir(n) )
264  case ( 1 ) ! EAST
265  do l=1,l_size
266  ptr_ebuffer = b_addrs(1, l, tMe)
267  do k = 1, ke
268  index = bound%recv(m)%index(n)
269  do j = js, je
270  do i = is, ie
271  pos = pos + 1
272  ebuffer(index,k) = buffer(pos)
273  index = index + 1
274  end do
275  end do
276  end do
277  end do
278  case ( 2 ) ! SOUTH
279  do l=1,l_size
280  ptr_sbuffer = b_addrs(2, l, tMe)
281  do k = 1, ke
282  index = bound%recv(m)%index(n)
283  do j = js, je
284  do i = is, ie
285  pos = pos + 1
286  sbuffer(index,k) = buffer(pos)
287  index = index + 1
288  end do
289  end do
290  end do
291  end do
292  case ( 3 ) ! WEST
293  do l=1,l_size
294  ptr_wbuffer = b_addrs(3, l, tMe)
295  do k = 1, ke
296  index = bound%recv(m)%index(n)
297  do j = js, je
298  do i = is, ie
299  pos = pos + 1
300  wbuffer(index,k) = buffer(pos)
301  index = index + 1
302  end do
303  end do
304  end do
305  end do
306  case ( 4 ) ! norTH
307  do l=1,l_size
308  ptr_nbuffer = b_addrs(4, l, tMe)
309  do k = 1, ke
310  index = bound%recv(m)%index(n)
311  do j = js, je
312  do i = is, ie
313  pos = pos + 1
314  nbuffer(index,k) = buffer(pos)
315  index = index + 1
316  end do
317  end do
318  end do
319  end do
320  end select
321  end if
322  end do
323  end do
324 
325  call mpp_sync_self( )
326 
327 
328 end subroutine MPP_DO_GET_BOUNDARY_AD_3D_
329 
330 
331 subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, b_addrsx, b_addrsy, &
332  bsizex, bsizey, ke, d_type, flags, gridtype)
333  type(domain2D), intent(in) :: domain
334  type(overlapSpec), intent(in) :: boundx, boundy
335  integer(LONG_KIND), intent(in) :: f_addrsx(:,:), f_addrsy(:,:)
336  integer(LONG_KIND), intent(in) :: b_addrsx(:,:,:), b_addrsy(:,:,:)
337  integer, intent(in) :: bsizex(:), bsizey(:), ke
338  MPP_TYPE_, intent(in) :: d_type ! creates unique interface
339  integer, intent(in) :: flags
340  integer, intent(in) :: gridtype
341 
342  MPP_TYPE_ :: fieldx(boundx%xbegin:boundx%xend, boundx%ybegin:boundx%yend,ke)
343  MPP_TYPE_ :: fieldy(boundy%xbegin:boundy%xend, boundy%ybegin:boundy%yend,ke)
344  MPP_TYPE_ :: ebufferx(bsizex(1), ke), sbufferx(bsizex(2), ke), wbufferx(bsizex(3), ke), nbufferx(bsizex(4), ke)
345  MPP_TYPE_ :: ebuffery(bsizey(1), ke), sbuffery(bsizey(2), ke), wbuffery(bsizey(3), ke), nbuffery(bsizey(4), ke)
346  pointer(ptr_fieldx, fieldx)
347  pointer(ptr_fieldy, fieldy)
348  pointer(ptr_ebufferx, ebufferx)
349  pointer(ptr_sbufferx, sbufferx)
350  pointer(ptr_wbufferx, wbufferx)
351  pointer(ptr_nbufferx, nbufferx)
352  pointer(ptr_ebuffery, ebuffery)
353  pointer(ptr_sbuffery, sbuffery)
354  pointer(ptr_wbuffery, wbuffery)
355  pointer(ptr_nbuffery, nbuffery)
356 
357  integer, allocatable :: msg1(:), msg2(:)
358  logical :: recvx(4), sendx(4)
359  logical :: recvy(4), sendy(4)
360  integer :: nlist, buffer_pos,buffer_pos_old, pos, pos_, tMe, m
361  integer :: is, ie, js, je, msgsize, l_size, buffer_recv_size, msgsize_send
362  integer :: i, j, k, l, n, index, to_pe, from_pe
363  integer :: rank_x, rank_y, cur_rank, ind_x, ind_y
364  integer :: nsend_x, nsend_y, nrecv_x, nrecv_y, num
365  character(len=8) :: text
366  integer :: outunit, shift, midpoint
367 
368  MPP_TYPE_ :: buffer(size(mpp_domains_stack(:)))
369  pointer( ptr, buffer )
370  ptr = LOC(mpp_domains_stack)
371 
372  outunit = stdout()
373  l_size = size(f_addrsx,1)
374  !---- determine recv(1) based on b_addrs ( east boundary )
375  num = count(b_addrsx(1,:,1) == 0)
376  if( num == 0 ) then
377  recvx(1) = .true.
378  else if( num == l_size ) then
379  recvx(1) = .false.
380  else
381  if( num .NE. 0 ) call mpp_error(FATAL, &
382  "mpp_do_get_boundary_V: number of ebufferx with null address should be 0 or l_size")
383  endif
384 
385  !---- determine recv(2) based on b_addrs ( south boundary )
386  num = count(b_addrsx(2,:,1) == 0)
387  if( num == 0 ) then
388  recvx(2) = .true.
389  else if( num == l_size ) then
390  recvx(2) = .false.
391  else
392  if( num .NE. 0 ) call mpp_error(FATAL, &
393  "mpp_do_get_boundary_V: number of sbufferx with null address should be 0 or l_size")
394  endif
395 
396  !---- determine recv(3) based on b_addrs ( west boundary )
397  num = count(b_addrsx(3,:,1) == 0)
398  if( num == 0 ) then
399  recvx(3) = .true.
400  else if( num == l_size ) then
401  recvx(3) = .false.
402  else
403  if( num .NE. 0 ) call mpp_error(FATAL, &
404  "mpp_do_get_boundary_V: number of wbufferx with null address should be 0 or l_size")
405  endif
406 
407  !---- determine recv(4) based on b_addrs ( north boundary )
408  num = count(b_addrsx(4,:,1) == 0)
409  if( num == 0 ) then
410  recvx(4) = .true.
411  else if( num == l_size ) then
412  recvx(4) = .false.
413  else
414  if( num .NE. 0 ) call mpp_error(FATAL, &
415  "mpp_do_get_boundary_V: number of nbufferx with null address should be 0 or l_size")
416  endif
417 
418  !---- determine recv(1) based on b_addrs ( east boundary )
419  num = count(b_addrsy(1,:,1) == 0)
420  if( num == 0 ) then
421  recvy(1) = .true.
422  else if( num == l_size ) then
423  recvy(1) = .false.
424  else
425  if( num .NE. 0 ) call mpp_error(FATAL, &
426  "mpp_do_get_boundary_V: number of ebuffery with null address should be 0 or l_size")
427  endif
428 
429  !---- determine recv(2) based on b_addrs ( south boundary )
430  num = count(b_addrsy(2,:,1) == 0)
431  if( num == 0 ) then
432  recvy(2) = .true.
433  else if( num == l_size ) then
434  recvy(2) = .false.
435  else
436  if( num .NE. 0 ) call mpp_error(FATAL, &
437  "mpp_do_get_boundary_V: number of sbuffery with null address should be 0 or l_size")
438  endif
439 
440  !---- determine recv(3) based on b_addrs ( west boundary )
441  num = count(b_addrsy(3,:,1) == 0)
442  if( num == 0 ) then
443  recvy(3) = .true.
444  else if( num == l_size ) then
445  recvy(3) = .false.
446  else
447  if( num .NE. 0 ) call mpp_error(FATAL, &
448  "mpp_do_get_boundary_V: number of wbuffery with null address should be 0 or l_size")
449  endif
450 
451  !---- determine recv(4) based on b_addrs ( north boundary )
452  num = count(b_addrsy(4,:,1) == 0)
453  if( num == 0 ) then
454  recvy(4) = .true.
455  else if( num == l_size ) then
456  recvy(4) = .false.
457  else
458  if( num .NE. 0 ) call mpp_error(FATAL, &
459  "mpp_do_get_boundary_V: number of nbuffery with null address should be 0 or l_size")
460  endif
461 
462  sendx = recvx
463  sendy = recvy
464 
465  nlist = size(domain%list(:))
466 
467  nsend_x = boundx%nsend
468  nsend_y = boundy%nsend
469  nrecv_x = boundx%nrecv
470  nrecv_y = boundy%nrecv
471 
472  if(debug_message_passing) then
473  allocate(msg1(0:nlist-1), msg2(0:nlist-1) )
474  msg1 = 0
475  msg2 = 0
476 
477  cur_rank = get_rank_recv(domain, boundx, boundy, rank_x, rank_y, ind_x, ind_y)
478 
479  do while ( ind_x .LE. nrecv_x .OR. ind_y .LE. nrecv_y )
480  msgsize = 0
481  if(cur_rank == rank_x) then
482  from_pe = boundx%recv(ind_x)%pe
483  do n = 1, boundx%recv(ind_x)%count
484  if(recvx(boundx%recv(ind_x)%dir(n))) then
485  is = boundx%recv(ind_x)%is(n); ie = boundx%recv(ind_x)%ie(n)
486  js = boundx%recv(ind_x)%js(n); je = boundx%recv(ind_x)%je(n)
487  msgsize = msgsize + (ie-is+1)*(je-js+1)
488  end if
489  end do
490  ind_x = ind_x+1
491  if(ind_x .LE. nrecv_x) then
492  rank_x = boundx%recv(ind_x)%pe - domain%pe
493  if(rank_x .LE.0) rank_x = rank_x + nlist
494  else
495  rank_x = -1
496  endif
497  endif
498 
499  if(cur_rank == rank_y) then
500  from_pe = boundy%recv(ind_y)%pe
501  do n = 1, boundy%recv(ind_y)%count
502  if(recvy(boundy%recv(ind_y)%dir(n))) then
503  is = boundy%recv(ind_y)%is(n); ie = boundy%recv(ind_y)%ie(n)
504  js = boundy%recv(ind_y)%js(n); je = boundy%recv(ind_y)%je(n)
505  msgsize = msgsize + (ie-is+1)*(je-js+1)
506  end if
507  end do
508  ind_y = ind_y+1
509  if(ind_y .LE. nrecv_y) then
510  rank_y = boundy%recv(ind_y)%pe - domain%pe
511  if(rank_y .LE.0) rank_y = rank_y + nlist
512  else
513  rank_y = -1
514  endif
515  endif
516  cur_rank = max(rank_x, rank_y)
517  m = from_pe-mpp_root_pe()
518  call mpp_recv( msg1(m), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_3)
519  msg2(m) = msgsize
520  end do
521 
522  cur_rank = get_rank_send(domain, boundx, boundy, rank_x, rank_y, ind_x, ind_y)
523  do while (ind_x .LE. nsend_x .OR. ind_y .LE. nsend_y)
524  msgsize = 0
525  if(cur_rank == rank_x) then
526  to_pe = boundx%send(ind_x)%pe
527  do n = 1, boundx%send(ind_x)%count
528  if(sendx(boundx%send(ind_x)%dir(n))) then
529  is = boundx%send(ind_x)%is(n); ie = boundx%send(ind_x)%ie(n)
530  js = boundx%send(ind_x)%js(n); je = boundx%send(ind_x)%je(n)
531  msgsize = msgsize + (ie-is+1)*(je-js+1)
532  endif
533  enddo
534  ind_x = ind_x+1
535  if(ind_x .LE. nsend_x) then
536  rank_x = boundx%send(ind_x)%pe - domain%pe
537  if(rank_x .LT.0) rank_x = rank_x + nlist
538  else
539  rank_x = nlist+1
540  endif
541  endif
542 
543  if(cur_rank == rank_y) then
544  to_pe = boundy%send(ind_y)%pe
545  do n = 1, boundy%send(ind_y)%count
546  if(sendy(boundy%send(ind_y)%dir(n))) then
547  is = boundy%send(ind_y)%is(n); ie = boundy%send(ind_y)%ie(n)
548  js = boundy%send(ind_y)%js(n); je = boundy%send(ind_y)%je(n)
549  msgsize = msgsize + (ie-is+1)*(je-js+1)
550  end if
551  end do
552  ind_y = ind_y+1
553  if(ind_y .LE. nsend_y) then
554  rank_y = boundy%send(ind_y)%pe - domain%pe
555  if(rank_y .LT.0) rank_y = rank_y + nlist
556  else
557  rank_y = nlist+1
558  endif
559  endif
560  cur_rank = min(rank_x, rank_y)
561  call mpp_send( msgsize, plen=1, to_pe=to_pe, tag=COMM_TAG_3)
562  enddo
563 
564  call mpp_sync_self(check=EVENT_RECV)
565  do m = 0, nlist-1
566  if(msg1(m) .NE. msg2(m)) then
567  print*, "My pe = ", mpp_pe(), ",domain name =", trim(domain%name), ",from pe=", &
568  domain%list(m)%pe, ":send size = ", msg1(m), ", recv size = ", msg2(m)
569  call mpp_error(FATAL, "mpp_do_get_boundaryV: mismatch on send and recv size")
570  endif
571  enddo
572 
573  call mpp_sync_self()
574  write(outunit,*)"NOTE from mpp_do_get_boundary_V: message sizes are matched between send and recv for domain " &
575  //trim(domain%name)
576  deallocate(msg1, msg2)
577  endif
578 
579  !--- domain always is symmetry
580  shift = 1
581  tMe = 1
582  if( BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then
583  j = domain%y(1)%global%end+shift
584  if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain
585  !poles set to 0: BGRID only
586  if( gridtype.EQ.BGRID_NE )then
587  midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2
588  j = domain%y(1)%global%end+shift - domain%y(1)%compute%begin + 1
589  is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift
590  do i = is ,ie, midpoint
591  if( domain%x(1)%compute%begin == i )then
592  do l=1,l_size
593  ptr_wbufferx = b_addrsx(3, l, tMe)
594  ptr_wbuffery = b_addrsy(3, l, tMe)
595  do k = 1,ke
596  wbufferx(j,k) = 0
597  wbuffery(j,k) = 0
598  end do
599  end do
600  end if
601  end do
602  endif
603  endif
604  endif
605 
606  call mpp_sync_self( )
607 
608  !unpack recv
609  !unpack buffer in reverse order.
610  buffer_pos = 0
611  cur_rank = get_rank_recv(domain, boundx, boundy, rank_x, rank_y, ind_x, ind_y)
612  do while ( ind_x .LE. nrecv_x .OR. ind_y .LE. nrecv_y )
613  msgsize = 0
614  if(cur_rank == rank_x) then
615  from_pe = boundx%recv(ind_x)%pe
616  do n = 1, boundx%recv(ind_x)%count
617  if(recvx(boundx%recv(ind_x)%dir(n))) then
618  is = boundx%recv(ind_x)%is(n); ie = boundx%recv(ind_x)%ie(n)
619  js = boundx%recv(ind_x)%js(n); je = boundx%recv(ind_x)%je(n)
620  msgsize = msgsize + (ie-is+1)*(je-js+1)
621  end if
622  end do
623  ind_x = ind_x+1
624  if(ind_x .LE. nrecv_x) then
625  rank_x = boundx%recv(ind_x)%pe - domain%pe
626  if(rank_x .LE.0) rank_x = rank_x + nlist
627  else
628  rank_x = -1
629  endif
630  endif
631 
632  if(cur_rank == rank_y) then
633  from_pe = boundy%recv(ind_y)%pe
634  do n = 1, boundy%recv(ind_y)%count
635  if(recvy(boundy%recv(ind_y)%dir(n))) then
636  is = boundy%recv(ind_y)%is(n); ie = boundy%recv(ind_y)%ie(n)
637  js = boundy%recv(ind_y)%js(n); je = boundy%recv(ind_y)%je(n)
638  msgsize = msgsize + (ie-is+1)*(je-js+1)
639  end if
640  end do
641  ind_y = ind_y+1
642  if(ind_y .LE. nrecv_y) then
643  rank_y = boundy%recv(ind_y)%pe - domain%pe
644  if(rank_y .LE.0) rank_y = rank_y + nlist
645  else
646  rank_y = -1
647  endif
648  endif
649  cur_rank = max(rank_x, rank_y)
650  msgsize = msgsize*ke*l_size
651  if( msgsize.GT.0 )then
652  buffer_pos = buffer_pos + msgsize
653  end if
654  end do
655  buffer_recv_size = buffer_pos
656 
657  cur_rank = get_rank_unpack(domain, boundx, boundy, rank_x, rank_y, ind_x, ind_y)
658 
659  do while(ind_x >0 .OR. ind_y >0)
660  if(cur_rank == rank_y) then
661  do n = boundy%recv(ind_y)%count, 1, -1
662  if(recvy(boundy%recv(ind_y)%dir(n))) then
663  is = boundy%recv(ind_y)%is(n); ie = boundy%recv(ind_y)%ie(n)
664  js = boundy%recv(ind_y)%js(n); je = boundy%recv(ind_y)%je(n)
665  msgsize = (ie-is+1)*(je-js+1)*ke*l_size
666  pos = buffer_pos - msgsize
667  buffer_pos = pos
668  tMe = boundy%recv(ind_y)%tileMe(n)
669  select case( boundy%recv(ind_y)%dir(n) )
670  case ( 1 ) ! EAST
671  do l=1,l_size
672  ptr_ebuffery = b_addrsy(1, l, tMe)
673  do k = 1, ke
674  index = boundy%recv(ind_y)%index(n)
675  do j = js, je
676  do i = is, ie
677  pos = pos + 1
678  buffer(pos) = ebuffery(index,k)
679  ebuffery(index,k) = 0.
680  index = index + 1
681  end do
682  end do
683  end do
684  end do
685  case ( 2 ) ! SOUTH
686  do l=1,l_size
687  ptr_sbuffery = b_addrsy(2, l, tMe)
688  do k = 1, ke
689  index = boundy%recv(ind_y)%index(n)
690  do j = js, je
691  do i = is, ie
692  pos = pos + 1
693  buffer(pos) = sbuffery(index,k)
694  sbuffery(index,k) = 0.
695  index = index + 1
696  end do
697  end do
698  end do
699  end do
700  case ( 3 ) ! WEST
701  do l=1,l_size
702  ptr_wbuffery = b_addrsy(3, l, tMe)
703  do k = 1, ke
704  index = boundy%recv(ind_y)%index(n)
705  do j = js, je
706  do i = is, ie
707  pos = pos + 1
708  buffer(pos) = wbuffery(index,k)
709  wbuffery(index,k) = 0.
710  index = index + 1
711  end do
712  end do
713  end do
714  end do
715  case ( 4 ) ! norTH
716  do l=1,l_size
717  ptr_nbuffery = b_addrsy(4, l, tMe)
718  do k = 1, ke
719  index = boundy%recv(ind_y)%index(n)
720  do j = js, je
721  do i = is, ie
722  pos = pos + 1
723  buffer(pos) = nbuffery(index,k)
724  nbuffery(index,k) = 0.
725  index = index + 1
726  end do
727  end do
728  end do
729  end do
730  end select
731  end if
732  end do
733  ind_y = ind_y-1
734  if(ind_y .GT. 0) then
735  rank_y = boundy%recv(ind_y)%pe - domain%pe
736  if(rank_y .LE.0) rank_y = rank_y + nlist
737  else
738  rank_y = nlist+1
739  endif
740  endif
741 
742  if(cur_rank == rank_x) then
743  do n = boundx%recv(ind_x)%count, 1, -1
744  if(recvx(boundx%recv(ind_x)%dir(n))) then
745  is = boundx%recv(ind_x)%is(n); ie = boundx%recv(ind_x)%ie(n)
746  js = boundx%recv(ind_x)%js(n); je = boundx%recv(ind_x)%je(n)
747  msgsize = (ie-is+1)*(je-js+1)*ke*l_size
748  pos = buffer_pos - msgsize
749  buffer_pos = pos
750  tMe = boundx%recv(ind_x)%tileMe(n)
751  select case( boundx%recv(ind_x)%dir(n) )
752  case ( 1 ) ! EAST
753  do l=1,l_size
754  ptr_ebufferx = b_addrsx(1, l, tMe)
755  do k = 1, ke
756  index = boundx%recv(ind_x)%index(n)
757  do j = js, je
758  do i = is, ie
759  pos = pos + 1
760  buffer(pos) = ebufferx(index,k)
761  ebufferx(index,k) = 0.
762  index = index + 1
763  end do
764  end do
765  end do
766  end do
767  case ( 2 ) ! SOUTH
768  do l=1,l_size
769  ptr_sbufferx = b_addrsx(2, l, tMe)
770  do k = 1, ke
771  index = boundx%recv(ind_x)%index(n)
772  do j = js, je
773  do i = is, ie
774  pos = pos + 1
775  buffer(pos) = sbufferx(index,k)
776  sbufferx(index,k) = 0.
777  index = index + 1
778  end do
779  end do
780  end do
781  end do
782  case ( 3 ) ! WEST
783  do l=1,l_size
784  ptr_wbufferx = b_addrsx(3, l, tMe)
785  do k = 1, ke
786  index = boundx%recv(ind_x)%index(n)
787  do j = js, je
788  do i = is, ie
789  pos = pos + 1
790  buffer(pos) = wbufferx(index,k)
791  wbufferx(index,k) = 0.
792  index = index + 1
793  end do
794  end do
795  end do
796  end do
797  case ( 4 ) ! norTH
798  do l=1,l_size
799  ptr_nbufferx = b_addrsx(4, l, tMe)
800  do k = 1, ke
801  index = boundx%recv(ind_x)%index(n)
802  do j = js, je
803  do i = is, ie
804  pos = pos + 1
805  buffer(pos) = nbufferx(index,k)
806  nbufferx(index,k) = 0.
807  index = index + 1
808  end do
809  end do
810  end do
811  end do
812  end select
813  end if
814  end do
815  ind_x = ind_x-1
816  if(ind_x .GT. 0) then
817  rank_x = boundx%recv(ind_x)%pe - domain%pe
818  if(rank_x .LE.0) rank_x = rank_x + nlist
819  else
820  rank_x = nlist+1
821  endif
822  endif
823  cur_rank = min(rank_x, rank_y)
824  end do
825 
826  !recv
827  buffer_pos = 0
828  cur_rank = get_rank_recv(domain, boundx, boundy, rank_x, rank_y, ind_x, ind_y)
829 
830  do while ( ind_x .LE. nrecv_x .OR. ind_y .LE. nrecv_y )
831  msgsize = 0
832  if(cur_rank == rank_x) then
833  from_pe = boundx%recv(ind_x)%pe
834  do n = 1, boundx%recv(ind_x)%count
835  if(recvx(boundx%recv(ind_x)%dir(n))) then
836  is = boundx%recv(ind_x)%is(n); ie = boundx%recv(ind_x)%ie(n)
837  js = boundx%recv(ind_x)%js(n); je = boundx%recv(ind_x)%je(n)
838  msgsize = msgsize + (ie-is+1)*(je-js+1)
839  msgsize_send = (ie-is+1)*(je-js+1)*ke*l_size
840  end if
841  end do
842  ind_x = ind_x+1
843  if(ind_x .LE. nrecv_x) then
844  rank_x = boundx%recv(ind_x)%pe - domain%pe
845  if(rank_x .LE.0) rank_x = rank_x + nlist
846  else
847  rank_x = -1
848  endif
849  endif
850 
851  if(cur_rank == rank_y) then
852  from_pe = boundy%recv(ind_y)%pe
853  do n = 1, boundy%recv(ind_y)%count
854  if(recvy(boundy%recv(ind_y)%dir(n))) then
855  is = boundy%recv(ind_y)%is(n); ie = boundy%recv(ind_y)%ie(n)
856  js = boundy%recv(ind_y)%js(n); je = boundy%recv(ind_y)%je(n)
857  msgsize = msgsize + (ie-is+1)*(je-js+1)
858  msgsize_send = (ie-is+1)*(je-js+1)*ke*l_size
859  end if
860  end do
861  ind_y = ind_y+1
862  if(ind_y .LE. nrecv_y) then
863  rank_y = boundy%recv(ind_y)%pe - domain%pe
864  if(rank_y .LE.0) rank_y = rank_y + nlist
865  else
866  rank_y = -1
867  endif
868  endif
869  cur_rank = max(rank_x, rank_y)
870  msgsize = msgsize*ke*l_size
871  if( msgsize.GT.0 )then
872  call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=from_pe, tag=COMM_TAG_4 )
873  buffer_pos = buffer_pos + msgsize
874  end if
875  end do
876  buffer_recv_size = buffer_pos
877 
878  ! send
879  cur_rank = get_rank_send(domain, boundx, boundy, rank_x, rank_y, ind_x, ind_y)
880 
881  do while (ind_x .LE. nsend_x .OR. ind_y .LE. nsend_y)
882  pos = buffer_pos
883  if(cur_rank == rank_x) then
884  to_pe = boundx%send(ind_x)%pe
885  do n = 1, boundx%send(ind_x)%count
886  if(sendx(boundx%send(ind_x)%dir(n))) then
887  is = boundx%send(ind_x)%is(n); ie = boundx%send(ind_x)%ie(n)
888  js = boundx%send(ind_x)%js(n); je = boundx%send(ind_x)%je(n)
889  tMe = boundx%send(ind_x)%tileMe(n)
890  pos = pos + (ie-is+1)*(je-js+1)*ke*l_size
891  end if ! if(send(boundx%dir(n)))
892  end do !do n = 1, boundx%count
893  ind_x = ind_x+1
894  if(ind_x .LE. nsend_x) then
895  rank_x = boundx%send(ind_x)%pe - domain%pe
896  if(rank_x .LT.0) rank_x = rank_x + nlist
897  else
898  rank_x = nlist+1
899  endif
900  endif
901 
902  if(cur_rank == rank_y) then
903  to_pe = boundy%send(ind_y)%pe
904  do n = 1, boundy%send(ind_y)%count
905  if(sendy(boundy%send(ind_y)%dir(n))) then
906  is = boundy%send(ind_y)%is(n); ie = boundy%send(ind_y)%ie(n)
907  js = boundy%send(ind_y)%js(n); je = boundy%send(ind_y)%je(n)
908  tMe = boundy%send(ind_y)%tileMe(n)
909  pos = pos + (ie-is+1)*(je-js+1)*ke*l_size
910  end if ! if(send(boundy%dir(n)))
911  end do ! do n = 1, boundy%count
912  ind_y = ind_y+1
913  if(ind_y .LE. nsend_y) then
914  rank_y = boundy%send(ind_y)%pe - domain%pe
915  if(rank_y .LT.0) rank_y = rank_y + nlist
916  else
917  rank_y = nlist+1
918  endif
919  endif
920  cur_rank = min(rank_x, rank_y)
921  msgsize = pos - buffer_pos
922  if( msgsize.GT.0 )then
923  !--- maybe we do not need the following stack size check.
924  mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos )
925  if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then
926  write( text,'(i8)' )mpp_domains_stack_hwm
927  call mpp_error( FATAL, 'MPP_DO_GET_BOUNDARY_V_: mpp_domains_stack overflow, ' // &
928  'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.')
929  end if
930  call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=to_pe, block=.FALSE., tag=COMM_TAG_4 )
931  buffer_pos = pos
932  end if
933 
934  end do
935 
936  call mpp_sync_self(check=EVENT_RECV)
937 
938 !send second part---------------------------------------------------------------
939  buffer_pos = buffer_recv_size
940 
941  cur_rank = get_rank_send(domain, boundx, boundy, rank_x, rank_y, ind_x, ind_y)
942  buffer_pos_old = buffer_pos
943  pos = buffer_pos
944 
945  do while (ind_x .LE. nsend_x .OR. ind_y .LE. nsend_y)
946  pos = buffer_pos
947  if(cur_rank == rank_x) then
948  to_pe = boundx%send(ind_x)%pe
949  do n = boundx%send(ind_x)%count,1,-1
950  if(sendx(boundx%send(ind_x)%dir(n))) then
951  is = boundx%send(ind_x)%is(n); ie = boundx%send(ind_x)%ie(n)
952  js = boundx%send(ind_x)%js(n); je = boundx%send(ind_x)%je(n)
953  tMe = boundx%send(ind_x)%tileMe(n)
954  select case( boundx%send(ind_x)%rotation(n) )
955  case(ZERO)
956  do l=1,l_size
957  ptr_fieldx = f_addrsx(l, tMe)
958  do k = 1, ke
959  do j = js, je
960  do i = is, ie
961  pos = pos + 1
962  fieldx(i,j,k)= fieldx(i,j,k)+ buffer(pos)
963  end do
964  end do
965  end do
966  end do
967  case( MINUS_NINETY )
968  if( BTEST(flags,SCALAR_BIT) ) then
969  do l=1,l_size
970  ptr_fieldy = f_addrsy(l, tMe)
971  do k = 1, ke
972  do j = je, js, -1
973  do i = is, ie
974  pos = pos + 1
975  fieldy(i,j,k)= fieldy(i,j,k)+ buffer(pos)
976  end do
977  end do
978  end do
979  end do
980  else
981  do l=1,l_size
982  ptr_fieldy = f_addrsy(l, tMe)
983  do k = 1, ke
984  do j = je, js, -1
985  do i = is, ie
986  pos = pos + 1
987  fieldy(i,j,k)= fieldy(i,j,k)- buffer(pos)
988  end do
989  end do
990  end do
991  end do
992  end if
993  case( NINETY )
994  do l=1,l_size
995  ptr_fieldy = f_addrsy(l, tMe)
996  do k = 1, ke
997  do j = js, je
998  do i = ie, is, -1
999  pos = pos + 1
1000  fieldy(i,j,k)= fieldy(i,j,k)+ buffer(pos)
1001  end do
1002  end do
1003  end do
1004  end do
1005  case (ONE_HUNDRED_EIGHTY)
1006  if( BTEST(flags,SCALAR_BIT) ) then
1007  do l=1,l_size
1008  ptr_fieldx = f_addrsx(l, tMe)
1009  do k = 1, ke
1010  do j = je, js, -1
1011  do i = ie, is, -1
1012  pos = pos + 1
1013  fieldx(i,j,k)= fieldx(i,j,k)+ buffer(pos)
1014  end do
1015  end do
1016  end do
1017  end do
1018  else
1019  do l=1,l_size
1020  ptr_fieldx = f_addrsx(l, tMe)
1021  do k = 1, ke
1022  do j = je, js, -1
1023  do i = ie, is, -1
1024  pos = pos + 1
1025  fieldx(i,j,k)= fieldx(i,j,k)- buffer(pos)
1026  end do
1027  end do
1028  end do
1029  end do
1030  end if
1031  end select
1032  end if ! if(send(boundx%dir(n)))
1033  end do !do n = 1, boundx%count
1034  ind_x = ind_x+1
1035  if(ind_x .LE. nsend_x) then
1036  rank_x = boundx%send(ind_x)%pe - domain%pe
1037  if(rank_x .LT.0) rank_x = rank_x + nlist
1038  else
1039  rank_x = nlist+1
1040  endif
1041  endif
1042 
1043  if(cur_rank == rank_y) then
1044  to_pe = boundy%send(ind_y)%pe
1045  do n = boundy%send(ind_y)%count,1,-1
1046  if(sendy(boundy%send(ind_y)%dir(n))) then
1047  is = boundy%send(ind_y)%is(n); ie = boundy%send(ind_y)%ie(n)
1048  js = boundy%send(ind_y)%js(n); je = boundy%send(ind_y)%je(n)
1049  tMe = boundy%send(ind_y)%tileMe(n)
1050  select case( boundy%send(ind_y)%rotation(n) )
1051  case(ZERO)
1052  do l=1,l_size
1053  ptr_fieldy = f_addrsy(l, tMe)
1054  do k = 1, ke
1055  do j = js, je
1056  do i = is, ie
1057  pos = pos + 1
1058  fieldy(i,j,k)= fieldy(i,j,k)+ buffer(pos)
1059  end do
1060  end do
1061  end do
1062  end do
1063  case( MINUS_NINETY )
1064  do l=1,l_size
1065  ptr_fieldx = f_addrsx(l, tMe)
1066  do k = 1, ke
1067  do j = je, js, -1
1068  do i = is, ie
1069  pos = pos + 1
1070  fieldx(i,j,k)= fieldx(i,j,k)+ buffer(pos)
1071  end do
1072  end do
1073  end do
1074  end do
1075  case( NINETY )
1076  if( BTEST(flags,SCALAR_BIT) ) then
1077  do l=1,l_size
1078  ptr_fieldx = f_addrsx(l, tMe)
1079  do k = 1, ke
1080  do j = js, je
1081  do i = ie, is, -1
1082  pos = pos + 1
1083  fieldx(i,j,k)= fieldx(i,j,k)+ buffer(pos)
1084  end do
1085  end do
1086  end do
1087  end do
1088  else
1089  do l=1,l_size
1090  ptr_fieldx = f_addrsx(l, tMe)
1091  do k = 1, ke
1092  do j = js, je
1093  do i = ie, is, -1
1094  pos = pos + 1
1095  fieldx(i,j,k)= fieldx(i,j,k)- buffer(pos)
1096  end do
1097  end do
1098  end do
1099  end do
1100  end if
1101  case (ONE_HUNDRED_EIGHTY)
1102  if( BTEST(flags,SCALAR_BIT) ) then
1103  do l=1,l_size
1104  ptr_fieldy = f_addrsy(l, tMe)
1105  do k = 1, ke
1106  do j = je, js, -1
1107  do i = ie, is, -1
1108  pos = pos + 1
1109  fieldy(i,j,k)= fieldy(i,j,k)+ buffer(pos)
1110  end do
1111  end do
1112  end do
1113  end do
1114  else
1115  do l=1,l_size
1116  ptr_fieldy = f_addrsy(l, tMe)
1117  do k = 1, ke
1118  do j = je, js, -1
1119  do i = ie, is, -1
1120  pos = pos + 1
1121  fieldy(i,j,k)= fieldy(i,j,k)- buffer(pos)
1122  end do
1123  end do
1124  end do
1125  end do
1126  end if
1127  end select
1128  end if ! if(send(boundy%dir(n)))
1129  end do ! do n = 1, boundy%count
1130  ind_y = ind_y+1
1131  if(ind_y .LE. nsend_y) then
1132  rank_y = boundy%send(ind_y)%pe - domain%pe
1133  if(rank_y .LT.0) rank_y = rank_y + nlist
1134  else
1135  rank_y = nlist+1
1136  endif
1137  endif
1138 
1139  cur_rank = min(rank_x, rank_y)
1140  msgsize = pos - buffer_pos
1141  if( msgsize.GT.0 )then
1142  buffer_pos = pos
1143  end if
1144 
1145  end do
1146 
1147  call mpp_sync_self( )
1148 
1149 
1150 end subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_
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
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
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
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
mpp_domains_mod::wait_clock
integer wait_clock
Definition: mpp_domains.F90:673
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
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
mpp_domains_mod::mpp_domains_stack_size
integer mpp_domains_stack_size
Definition: mpp_domains.F90:612
external_ic_nlm_mod::reverse
real(fvprc) function, dimension(size(a, 1), size(a, 2)) reverse(A)
Definition: external_ic_nlm.F90:2955
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
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
type_diag::bound
real(kind_real), parameter bound
Definition: type_diag.F90:29
pos
l_size ! loop over number of fields ke do je do ie pos
Definition: mpp_do_redistribute.h:72
crtm_interpolation::order
integer, parameter, public order
Definition: CRTM_Interpolation.f90:70
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_get_boundary_ad.h:7
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