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