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