SCALE-RM
scale_comm_cartesC.F90
Go to the documentation of this file.
1 !-------------------------------------------------------------------------------
10 #include "scalelib.h"
11 module scale_comm_cartesc
12  !-----------------------------------------------------------------------------
13  !
14  !++ used modules
15  !
16 #ifdef NO_MPI08
17  use mpi
18 #else
19  use mpi_f08
20 #endif
21  use iso_c_binding
22  use scale_precision
23  use scale_io
24  use scale_prof
25  use scale_tracer
26 #ifdef _OPENACC
27  use openacc
28 #endif
29 
30  use scale_prc_cartesc, only: &
31  prc_next, &
32  prc_w, &
33  prc_n, &
34  prc_e, &
35  prc_s, &
36  prc_nw, &
37  prc_ne, &
38  prc_sw, &
39  prc_se, &
40  prc_has_w, &
41  prc_has_n, &
42  prc_has_e, &
43  prc_has_s
44  !-----------------------------------------------------------------------------
45  implicit none
46  private
47  !-----------------------------------------------------------------------------
48  !
49  !++ Public procedure
50  !
51  public :: comm_setup
52  public :: comm_regist
53  public :: comm_finalize
54  public :: comm_vars_init
55  public :: comm_vars8_init
56  public :: comm_vars
57  public :: comm_vars8
58  public :: comm_wait
59  public :: comm_gather
60  public :: comm_bcast
61 
62  interface comm_vars
63  module procedure comm_vars_2d
64  module procedure comm_vars_3d
65  end interface comm_vars
66 
67  interface comm_vars8
68  module procedure comm_vars8_2d
69  module procedure comm_vars8_3d
70  end interface comm_vars8
71 
72  interface comm_wait
73  module procedure comm_wait_2d
74  module procedure comm_wait_3d
75  end interface comm_wait
76 
77  interface comm_gather
78  module procedure comm_gather_2d
79  module procedure comm_gather_3d
80  end interface comm_gather
81 
82  interface comm_bcast
83  module procedure comm_bcast_scr_sp
84  module procedure comm_bcast_scr_dp
85  module procedure comm_bcast_1d_sp
86  module procedure comm_bcast_1d_dp
87  module procedure comm_bcast_2d_sp
88  module procedure comm_bcast_2d_dp
89  module procedure comm_bcast_3d_sp
90  module procedure comm_bcast_3d_dp
91  module procedure comm_bcast_4d_sp
92  module procedure comm_bcast_4d_dp
93  module procedure comm_bcast_int_scr
94  module procedure comm_bcast_int_1d
95  module procedure comm_bcast_int_2d
96  module procedure comm_bcast_logical_scr
97  module procedure comm_bcast_logical_1d
98  module procedure comm_bcast_character
99  end interface comm_bcast
100 
101  !-----------------------------------------------------------------------------
102  !
103  !++ Public parameters & variables
104  !
105  integer, public :: comm_datatype
106  integer, public :: comm_world
107 
108  !-----------------------------------------------------------------------------
109  !
110  !++ Private procedure
111  !
112  !-----------------------------------------------------------------------------
113  !
114  !++ Private parameters & variables
115  !
116  integer, private :: comm_vsize_max
117  integer, private :: comm_vsize_max_pc
118 
119  logical, private :: comm_isallperiodic
120 
121  logical, private :: comm_use_mpi_pc = .true.
122 #ifdef __FUJITSU
123  logical, private :: comm_use_mpi_onesided = .true.
124 #else
125  logical, private :: comm_use_mpi_onesided = .false.
126 #endif
127 
128 #ifdef NO_MPI08
129  integer, private :: comm_datatype_t
130  integer, private :: comm_world_t
131 #else
132  type(mpi_datatype), private :: comm_datatype_t
133  type(mpi_comm), private :: comm_world_t
134 #endif
135 
136 #ifdef _OPENACC
137  type ptr_t
138  real(rp), pointer :: ptr(:,:,:)
139  end type ptr_t
140 #endif
141  type ginfo_t
142  integer :: ka
143  integer :: ia, is, ie, ihalo
144  integer :: ja, js, je, jhalo
145  integer :: nreq_max
146  integer :: size2d_ns4
147  integer :: size2d_ns8
148  integer :: size2d_we
149  integer :: size2d_4c
150  integer :: vars_num = 0
151  real(rp), pointer :: recvpack_we2p(:,:,:)
152  real(rp), pointer :: sendpack_p2we(:,:,:)
153  type(c_ptr), allocatable :: recvbuf_we(:)
154  type(c_ptr), allocatable :: recvbuf_ns(:)
155  integer, allocatable :: req_cnt (:)
156  integer, allocatable :: preq_cnt (:)
157  integer, allocatable :: packid(:)
158 #if NO_MPI08
159  integer, allocatable :: req_list(:,:)
160  integer, allocatable :: preq_list(:,:)
161  integer, allocatable :: win_packwe(:)
162  integer, allocatable :: win_packns(:)
163 #else
164  type(mpi_request), allocatable :: req_list(:,:)
165  type(mpi_request), allocatable :: preq_list(:,:)
166  type(mpi_win), allocatable :: win_packwe(:)
167  type(mpi_win), allocatable :: win_packns(:)
168 #endif
169 #ifdef DEBUG
170  logical, allocatable :: use_packbuf(:)
171 #endif
172 #ifdef _OPENACC
173  logical, allocatable :: device_alloc(:)
174  type(ptr_t), allocatable :: device_ptr(:)
175 #endif
176  end type ginfo_t
177 
178  integer, private, parameter :: comm_gid_max = 20
179  integer, private :: comm_gid
180  type(ginfo_t), private :: ginfo(comm_gid_max)
181 
182 #if NO_MPI08
183  integer, private :: group_packwe
184  integer, private :: group_packns
185 #else
186  type(mpi_group), private :: group_packwe
187  type(mpi_group), private :: group_packns
188 #endif
189  logical, private :: group_packwe_created = .false.
190  logical, private :: group_packns_created = .false.
191 
192  logical, private :: initialized = .false.
193 
194  !-----------------------------------------------------------------------------
195 contains
196 
197  !-----------------------------------------------------------------------------
199  subroutine comm_setup
200  use scale_prc, only: &
201  prc_abort, &
202  prc_local_comm_world
203  use scale_prc_cartesc, only: &
204  prc_twod
205  implicit none
206 
207  namelist / param_comm_cartesc / &
208  comm_vsize_max, &
209  comm_vsize_max_pc, &
210  comm_use_mpi_pc, &
211  comm_use_mpi_onesided
212 
213  integer :: ranks(8)
214 #ifdef NO_MPI08
215  integer :: group
216 #else
217  type(mpi_group) :: group
218 #endif
219 
220  integer :: n, m
221  integer :: ierr
222  !---------------------------------------------------------------------------
223 
224  if ( initialized ) return
225 
226  log_newline
227  log_info("COMM_setup",*) 'Setup'
228 
229  comm_vsize_max = max( 10 + qa*2, 25 )
230  comm_vsize_max_pc = 50 + qa*2
231 
232 #ifdef _OPENACC
233  comm_use_mpi_onesided = .false.
234 #endif
235 
236  !--- read namelist
237  rewind(io_fid_conf)
238  read(io_fid_conf,nml=param_comm_cartesc,iostat=ierr)
239  if( ierr < 0 ) then !--- missing
240  log_info("COMM_setup",*) 'Not found namelist. Default used.'
241  elseif( ierr > 0 ) then !--- fatal error
242  log_error("COMM_setup",*) 'Not appropriate names in namelist PARAM_COMM_CARTESC. Check!'
243  call prc_abort
244  endif
245  log_nml(param_comm_cartesc)
246 
247  if ( prc_has_n .AND. prc_has_s .AND. prc_has_w .AND. prc_has_e ) then
248  comm_isallperiodic = .true.
249  else
250  comm_isallperiodic = .false.
251  endif
252 
253  comm_world = prc_local_comm_world
254 
255  if ( rp == kind(0.d0) ) then
256  comm_datatype_t = mpi_double_precision
257  elseif( rp == kind(0.0) ) then
258  comm_datatype_t = mpi_real
259  else
260  log_error("COMM_setup",*) 'precision is not supportd'
261  call prc_abort
262  endif
263 
264 #ifdef NO_MPI08
265  comm_world_t = comm_world
266  comm_datatype = comm_datatype_t
267 #else
268  comm_world_t%MPI_VAL = comm_world
269  comm_datatype = comm_datatype_t%MPI_VAL
270 #endif
271 
272  comm_gid = 0
273 
274 #ifdef _OPENACC
275  if ( comm_use_mpi_onesided ) then
276  log_warn("COMM_setup",*) "Open MPI does not support one-sided APIs with CUDA-aware UCX"
277  end if
278 #endif
279 
280  if ( comm_use_mpi_onesided ) then
281 
282  comm_use_mpi_pc = .false.
283 
284  call mpi_comm_group( comm_world_t, group, ierr )
285 
286  n = 0
287  if ( prc_has_s ) then
288  n = 1
289  ranks(n) = prc_next(prc_s)
290  end if
291  if ( prc_has_n ) then
292  do m = 1, n
293  if ( ranks(m) == prc_next(prc_n) ) exit
294  end do
295  if ( m == n + 1 ) then
296  n = n + 1
297  ranks(n) = prc_next(prc_n)
298  end if
299  end if
300  if ( prc_has_n .and. prc_has_w ) then
301  do m = 1, n
302  if ( ranks(m) == prc_next(prc_nw) ) exit
303  end do
304  if ( m == n + 1 ) then
305  n = n + 1
306  ranks(n) = prc_next(prc_nw)
307  end if
308  else if ( prc_has_n ) then
309  do m = 1, n
310  if ( ranks(m) == prc_next(prc_n) ) exit
311  end do
312  if ( m == n + 1 ) then
313  n = n + 1
314  ranks(n) = prc_next(prc_n)
315  end if
316  else if ( prc_has_w ) then
317  do m = 1, n
318  if ( ranks(m) == prc_next(prc_w) ) exit
319  end do
320  if ( m == n + 1 ) then
321  n = n + 1
322  ranks(n) = prc_next(prc_w)
323  end if
324  end if
325  if ( prc_has_n .and. prc_has_e ) then
326  do m = 1, n
327  if ( ranks(m) == prc_next(prc_ne) ) exit
328  end do
329  if ( m == n + 1 ) then
330  n = n + 1
331  ranks(n) = prc_next(prc_ne)
332  end if
333  else if ( prc_has_n ) then
334  do m = 1, n
335  if ( ranks(m) == prc_next(prc_n) ) exit
336  end do
337  if ( m == n + 1 ) then
338  n = n + 1
339  ranks(n) = prc_next(prc_n)
340  end if
341  else if ( prc_has_e ) then
342  do m = 1, n
343  if ( ranks(m) == prc_next(prc_e) ) exit
344  end do
345  if ( m == n + 1 ) then
346  n = n + 1
347  ranks(n) = prc_next(prc_e)
348  end if
349  end if
350  if ( prc_has_s .and. prc_has_w ) then
351  do m = 1, n
352  if ( ranks(m) == prc_next(prc_sw) ) exit
353  end do
354  if ( m == n + 1 ) then
355  n = n + 1
356  ranks(n) = prc_next(prc_sw)
357  end if
358  else if ( prc_has_s ) then
359  do m = 1, n
360  if ( ranks(m) == prc_next(prc_s) ) exit
361  end do
362  if ( m == n + 1 ) then
363  n = n + 1
364  ranks(n) = prc_next(prc_s)
365  end if
366  else if ( prc_has_w ) then
367  do m = 1, n
368  if ( ranks(m) == prc_next(prc_w) ) exit
369  end do
370  if ( m == n + 1 ) then
371  n = n + 1
372  ranks(n) = prc_next(prc_w)
373  end if
374  end if
375  if ( prc_has_s .and. prc_has_e ) then
376  do m = 1, n
377  if ( ranks(m) == prc_next(prc_se) ) exit
378  end do
379  if ( m == n + 1 ) then
380  n = n + 1
381  ranks(n) = prc_next(prc_se)
382  end if
383  else if ( prc_has_s ) then
384  do m = 1, n
385  if ( ranks(m) == prc_next(prc_s) ) exit
386  end do
387  if ( m == n + 1 ) then
388  n = n + 1
389  ranks(n) = prc_next(prc_s)
390  end if
391  else if ( prc_has_e ) then
392  do m = 1, n
393  if ( ranks(m) == prc_next(prc_e) ) exit
394  end do
395  if ( m == n + 1 ) then
396  n = n + 1
397  ranks(n) = prc_next(prc_e)
398  end if
399  end if
400  if ( n > 0 ) then
401  call mpi_group_incl( group, n, ranks, group_packns, ierr )
402  group_packns_created = .true.
403  else
404  group_packns_created = .false.
405  end if
406 
407  n = 0
408  if ( .not. prc_twod ) then
409  if ( prc_has_w ) then
410  n = 1
411  ranks(n) = prc_next(prc_w)
412  end if
413  if ( prc_has_e ) then
414  if ( n == 0 .or. ranks(1) .ne. prc_next(prc_e) ) then
415  n = n + 1
416  ranks(n) = prc_next(prc_e)
417  end if
418  end if
419  end if
420  if ( n > 0 ) then
421  call mpi_group_incl( group, n, ranks, group_packwe, ierr )
422  group_packwe_created = .true.
423  else
424  group_packwe_created = .false.
425  end if
426 
427  call mpi_group_free( group, ierr )
428  end if
429 
430  log_newline
431  log_info("COMM_setup",*) 'Communication information'
432  log_info_cont(*) 'Maximum number of vars for one communication: ', comm_vsize_max
433  log_info_cont(*) 'All side is periodic? : ', comm_isallperiodic
434 
435 
436  initialized = .true.
437 
438  return
439  end subroutine comm_setup
440 
441  !-----------------------------------------------------------------------------
443  subroutine comm_regist( &
444  KA, IA, JA, IHALO, JHALO, &
445  gid )
446  use scale_prc, only: &
447  prc_abort
448  implicit none
449 
450  integer, intent(in) :: ka, ia, ja, ihalo, jhalo
451  integer, intent(out) :: gid
452 
453  integer :: imax, jmax
454  integer :: nreq_ns, nreq_we, nreq_4c
455 
456 #ifdef NO_MPI08
457  integer :: win_info
458 #else
459  type(mpi_info) :: win_info
460 #endif
461 
462  integer(kind=MPI_ADDRESS_KIND) :: size
463 
464  integer :: ierr
465  integer :: n
466 
467  if ( .not. initialized ) then
468  log_error("COMM_regist",*) 'COMM_setup must be called before calling COMM_regist'
469  call prc_abort
470  end if
471 
472  comm_gid = comm_gid + 1
473  if ( comm_gid > comm_gid_max ) then
474  log_error("COMM_regist",*) 'number of registed grid size exceeds the limit'
475  call prc_abort
476  end if
477  gid = comm_gid
478 
479  if ( ia < ihalo * 3 ) then
480  log_error("COMM_regist",*) 'IA must be >= IHALO * 3'
481  call prc_abort
482  end if
483  if ( ja < jhalo * 3 ) then
484  log_error("COMM_regist",*) 'JA must be >= JHALO * 3'
485  call prc_abort
486  end if
487 
488  imax = ia - ihalo * 2
489  jmax = ja - jhalo * 2
490 
491  ginfo(gid)%KA = ka
492  ginfo(gid)%IA = ia
493  ginfo(gid)%IS = ihalo + 1
494  ginfo(gid)%IE = ia - ihalo
495  ginfo(gid)%IHALO = ihalo
496  ginfo(gid)%JA = ja
497  ginfo(gid)%JS = jhalo + 1
498  ginfo(gid)%JE = ja - jhalo
499  ginfo(gid)%JHALO = jhalo
500 
501  nreq_ns = 2 * jhalo !--- send x JHALO, recv x JHALO
502  nreq_we = 2 !--- send x 1 , recv x 1
503  nreq_4c = 2 * jhalo !--- send x JHALO, recv x JHALO
504 
505  if ( comm_use_mpi_pc ) then
506  ginfo(gid)%nreq_MAX = 2 * nreq_ns + 2 * nreq_we + 4 * nreq_4c + 1
507  else
508  ginfo(gid)%nreq_MAX = 2 * nreq_ns + 2 * nreq_we + 4 * nreq_4c
509  end if
510 
511  ginfo(gid)%size2D_NS4 = ia * jhalo
512  ginfo(gid)%size2D_NS8 = imax
513  ginfo(gid)%size2D_WE = jmax * ihalo
514  ginfo(gid)%size2D_4C = ihalo
515 
516  allocate( ginfo(gid)%sendpack_P2WE(ginfo(gid)%size2D_WE * ka, 2, comm_vsize_max) )
517  !$acc enter data create(ginfo(gid)%sendpack_P2WE)
518 
519 #ifdef DEBUG
520  allocate( ginfo(gid)%use_packbuf(comm_vsize_max) )
521  ginfo(gid)%use_packbuf(:) = .false.
522 #endif
523 
524 #ifdef _OPENACC
525  allocate( ginfo(gid)%device_alloc(comm_vsize_max+comm_vsize_max_pc) )
526  allocate( ginfo(gid)%device_ptr(comm_vsize_max+1:comm_vsize_max_pc) )
527  ginfo(gid)%device_alloc(:) = .false.
528 #endif
529 
530  if ( comm_use_mpi_onesided ) then
531 
532  allocate( ginfo(gid)%recvbuf_WE(comm_vsize_max) )
533  allocate( ginfo(gid)%recvbuf_NS(comm_vsize_max) )
534 
535  allocate( ginfo(gid)%win_packWE(comm_vsize_max) )
536  allocate( ginfo(gid)%win_packNS(comm_vsize_max) )
537 
538  call mpi_info_create(win_info, ierr)
539  call mpi_info_set(win_info, "no_locks", "true", ierr)
540  call mpi_info_set(win_info, "same_size", "true", ierr)
541  call mpi_info_set(win_info, "same_disp_unit", "true", ierr)
542 
543  do n = 1, comm_vsize_max
544  size = ginfo(gid)%size2D_WE * ka * 2 * rp
545 #ifdef _OPENACC
546  block
547  real(rp), pointer :: pack(:)
548  call mpi_alloc_mem(size, mpi_info_null, ginfo(gid)%recvbuf_WE(n), ierr)
549  call c_f_pointer(ginfo(gid)%recvbuf_WE(n), pack, (/ size/rp /))
550  !$acc enter data create(pack)
551  !$acc host_data use_device(pack)
552  call mpi_win_create(pack, size, ginfo(gid)%size2D_WE*ka*rp, &
553  win_info, comm_world_t, &
554  ginfo(gid)%win_packWE(n), ierr)
555  !$acc end host_data
556  end block
557 #else
558  call mpi_win_allocate(size, ginfo(gid)%size2D_WE*ka*rp, &
559  win_info, comm_world_t, &
560  ginfo(gid)%recvbuf_WE(n), ginfo(gid)%win_packWE(n), ierr)
561 #endif
562  size = ginfo(gid)%size2D_NS4 * ka * 2 * rp
563 #ifdef _OPENACC
564  block
565  real(rp), pointer :: pack(:)
566  call mpi_alloc_mem(size, mpi_info_null, ginfo(gid)%recvbuf_NS(n), ierr)
567  call c_f_pointer(ginfo(gid)%recvbuf_NS(n), pack, (/ size/rp /))
568  !$acc enter data create(pack)
569  !$acc host_data use_device(pack)
570  call mpi_win_create(pack, size, rp, &
571  win_info, comm_world_t, &
572  ginfo(gid)%win_packNS(n), ierr)
573  !$acc end host_data
574  end block
575 #else
576  call mpi_win_allocate(size, rp, &
577  win_info, comm_world_t, &
578  ginfo(gid)%recvbuf_NS(n), ginfo(gid)%win_packNS(n), ierr)
579 #endif
580  end do
581 
582  call mpi_info_free(win_info, ierr)
583 
584  do n = 1, comm_vsize_max
585  call mpi_win_post( group_packwe, mpi_mode_nostore, ginfo(gid)%win_packWE(n), ierr )
586  call mpi_win_post( group_packns, mpi_mode_nostore, ginfo(gid)%win_packNS(n), ierr )
587  end do
588 
589  ginfo(gid)%vars_num = 0
590  allocate( ginfo(gid)%packid(comm_vsize_max_pc) )
591 
592  else
593 
594  allocate( ginfo(gid)%recvpack_WE2P(ginfo(gid)%size2D_WE * ka, 2, comm_vsize_max) )
595  !$acc enter data create(ginfo(gid)%recvpack_WE2P)
596 
597  allocate( ginfo(gid)%req_cnt ( comm_vsize_max) )
598  allocate( ginfo(gid)%req_list(ginfo(gid)%nreq_MAX, comm_vsize_max) )
599  ginfo(gid)%req_cnt (:) = -1
600  ginfo(gid)%req_list(:,:) = mpi_request_null
601 
602  if ( comm_use_mpi_pc ) then
603  ginfo(gid)%vars_num = 0
604  allocate( ginfo(gid)%packid(comm_vsize_max_pc) )
605  allocate( ginfo(gid)%preq_cnt ( comm_vsize_max_pc) )
606  allocate( ginfo(gid)%preq_list(ginfo(gid)%nreq_MAX+1,comm_vsize_max_pc) )
607  ginfo(gid)%preq_cnt (:) = -1
608  ginfo(gid)%preq_list(:,:) = mpi_request_null
609  end if
610 
611  end if
612 
613 
614  log_newline
615  log_info("COMM_regist",*) 'Register grid: id=', gid
616  log_info_cont(*) 'Data size of var (3D,including halo) [byte] : ', rp*ka*ia*ja
617  log_info_cont(*) 'Data size of halo [byte] : ', rp*ka*(2*ia*jhalo+2*jmax*ihalo)
618  log_info_cont(*) 'Ratio of halo against the whole 3D grid : ', real(2*ia*jhalo+2*jmax*ihalo) / real(ia*ja)
619 
620  return
621  end subroutine comm_regist
622 
623  !-----------------------------------------------------------------------------
625  subroutine comm_finalize
626  implicit none
627 
628  integer :: gid
629  integer :: i, j, ierr
630  !---------------------------------------------------------------------------
631 
632  do gid = 1, comm_gid
633 
634  if ( comm_use_mpi_onesided ) then
635 
636  do i = 1, comm_vsize_max
637  call mpi_win_start( group_packwe, 0, ginfo(gid)%win_packWE(i), ierr )
638  call mpi_win_start( group_packns, 0, ginfo(gid)%win_packNS(i), ierr )
639  end do
640 
641  do i = 1, comm_vsize_max
642  call mpi_win_complete( ginfo(gid)%win_packWE(i), ierr )
643  call mpi_win_complete( ginfo(gid)%win_packNS(i), ierr )
644  end do
645 
646  do i = 1, comm_vsize_max
647  call mpi_win_wait( ginfo(gid)%win_packWE(i), ierr )
648  call mpi_win_wait( ginfo(gid)%win_packNS(i), ierr )
649  end do
650 
651  do i = 1, comm_vsize_max
652  call mpi_win_free(ginfo(gid)%win_packWE(i), ierr)
653  call mpi_win_free(ginfo(gid)%win_packNS(i), ierr)
654 #ifdef _OPENACC
655  block
656  real(rp), pointer :: pack(:)
657  integer :: ka
658  ka = ginfo(gid)%KA
659  call c_f_pointer( ginfo(gid)%recvbuf_WE(i), pack, (/ginfo(gid)%size2D_WE*ka*2/) )
660  !$acc exit data delete(pack)
661  call c_f_pointer( ginfo(gid)%recvbuf_NS(i), pack, (/ginfo(gid)%size2D_NS4*ka*2/) )
662  !$acc exit data delete(pack)
663  end block
664  call mpi_free_mem(ginfo(gid)%recvbuf_WE(i), ierr)
665  call mpi_free_mem(ginfo(gid)%recvbuf_NS(i), ierr)
666 #endif
667  end do
668 
669  deallocate( ginfo(gid)%packid )
670  ginfo(gid)%vars_num = 0
671 
672  deallocate( ginfo(gid)%win_packWE )
673  deallocate( ginfo(gid)%win_packNS )
674 
675  deallocate( ginfo(gid)%recvbuf_WE )
676  deallocate( ginfo(gid)%recvbuf_NS )
677 
678  else
679 
680  if ( comm_use_mpi_pc ) then
681 
682  do j = 1, comm_vsize_max_pc
683  do i = 1, ginfo(gid)%nreq_MAX+1
684  if (ginfo(gid)%preq_list(i,j) .NE. mpi_request_null) &
685  call mpi_request_free(ginfo(gid)%preq_list(i,j), ierr)
686  enddo
687 #ifdef _OPENACC
688  if ( ginfo(gid)%device_alloc(j+comm_vsize_max) ) then
689  !$acc exit data delete(ginfo(gid)%device_ptr(j+COMM_vsize_max)%ptr)
690  end if
691 #endif
692  enddo
693  deallocate( ginfo(gid)%preq_cnt )
694  deallocate( ginfo(gid)%preq_list )
695  deallocate( ginfo(gid)%packid )
696  ginfo(gid)%vars_num = 0
697 
698  end if
699 
700  deallocate( ginfo(gid)%req_cnt )
701  deallocate( ginfo(gid)%req_list )
702 
703  !$acc exit data delete(ginfo(gid)%recvpack_WE2P)
704  deallocate( ginfo(gid)%recvpack_WE2P )
705 
706  end if
707 
708  !$acc exit data delete(ginfo(gid)%sendpack_P2WE)
709  deallocate( ginfo(gid)%sendpack_P2WE )
710 #ifdef DEBUG
711  deallocate( ginfo(gid)%use_packbuf )
712 #endif
713 
714  end do
715 
716  if ( comm_use_mpi_onesided ) then
717  if ( group_packwe_created ) then
718  call mpi_group_free(group_packwe, ierr)
719  group_packwe_created = .false.
720  end if
721  if ( group_packns_created ) then
722  call mpi_group_free(group_packns, ierr)
723  group_packns_created = .false.
724  end if
725  end if
726 
727 
728  comm_gid = 0
729 
730  initialized = .false.
731 
732  return
733  end subroutine comm_finalize
734 
735  !-----------------------------------------------------------------------------
737  subroutine comm_vars_init( &
738  varname, &
739  var, &
740  vid, &
741  gid )
742  use scale_prc, only: &
743  prc_abort
744  implicit none
745 
746  character(len=*), intent(in) :: varname
747  real(rp), target, intent(inout) :: var(:,:,:)
748  integer, intent(inout) :: vid
749 
750  integer, intent(in), optional :: gid
751 
752  integer :: gid_
753  integer :: vars_id
754  !---------------------------------------------------------------------------
755 
756  if ( .not. comm_use_mpi_pc ) return
757 #ifdef _OPENACC
758  if ( .not. acc_is_present(var) ) return
759 #endif
760 
761  call prof_rapstart('COMM_init_pers', 2)
762 
763  gid_ = 1
764  if ( present(gid) ) gid_ = gid
765  if ( gid_ > comm_gid_max ) then
766  log_error("COMM_vars_init",*) 'gid is invalid', gid_, comm_gid_max
767  call prc_abort
768  end if
769 
770  if ( vid > comm_vsize_max ) then
771  log_error("COMM_vars_init",*) 'vid exceeds max', vid, comm_vsize_max, gid
772  call prc_abort
773  end if
774 
775  ginfo(gid_)%vars_num = ginfo(gid_)%vars_num + 1
776  if ( ginfo(gid_)%vars_num > comm_vsize_max_pc ) then
777  log_error("COMM_vars_init",*) 'number of variable for MPI PC exceeds max', ginfo(gid_)%vars_num, comm_vsize_max_pc
778  call prc_abort
779  end if
780 
781  vars_id = ginfo(gid_)%vars_num
782  ginfo(gid_)%packid(vars_id) = vid
783 
784 #ifdef _OPENACC
785  if ( .not. acc_is_present(var) ) then
786  ginfo(gid_)%device_alloc(vars_id+comm_vsize_max) = .true.
787  ginfo(gid_)%device_ptr(vars_id*comm_vsize_max)%ptr => var
788  !$acc enter data copyin(var)
789  end if
790 #endif
791 
792  call vars_init_mpi_pc(var, gid_, vars_id, vid)
793 
794  vid = vars_id + comm_vsize_max
795 
796  log_info("COMM_vars_init",'(1x,A,I3.3,A,I3.3,2A)') 'Initialize variable (grid ID = ', gid_, '): ID = ', vid, &
797  ', name = ', trim(varname)
798 
799  call prof_rapend ('COMM_init_pers', 2)
800 
801  return
802  end subroutine comm_vars_init
803 
804  !-----------------------------------------------------------------------------
806  subroutine comm_vars8_init( &
807  varname, &
808  var, &
809  vid, &
810  gid )
811  use scale_prc, only: &
812  prc_abort
813  implicit none
814 
815  character(len=*), intent(in) :: varname
816 
817  real(rp), target, intent(inout) :: var(:,:,:)
818  integer, intent(inout) :: vid
819 
820  integer, intent(in), optional :: gid
821 
822  integer :: gid_
823  integer :: vars_id
824  !---------------------------------------------------------------------------
825 
826  if ( .not. comm_use_mpi_pc ) return
827 #ifdef _OPENACC
828  if ( .not. acc_is_present(var) ) return
829 #endif
830 
831  call prof_rapstart('COMM_init_pers', 2)
832 
833  gid_ = 1
834  if ( present(gid) ) gid_ = gid
835  if ( gid_ > comm_gid_max ) then
836  log_error("COMM_vars8_init",*) 'gid is invalid', gid_, comm_gid_max
837  call prc_abort
838  end if
839 
840  if ( vid > comm_vsize_max ) then
841  log_error("COMM_vars8_init",*) 'vid exceeds max', vid, comm_vsize_max
842  call prc_abort
843  end if
844 
845  ginfo(gid_)%vars_num = ginfo(gid_)%vars_num + 1
846  if ( ginfo(gid_)%vars_num > comm_vsize_max_pc ) then
847  log_error("COMM_vars8_init",*) 'number of variable for MPI PC exceeds max', ginfo(gid_)%vars_num, comm_vsize_max_pc
848  call prc_abort
849  end if
850 
851  vars_id = ginfo(gid_)%vars_num
852  ginfo(gid_)%packid(vars_id) = vid
853 
854 #ifdef _OPENACC
855  if ( .not. acc_is_present(var) ) then
856  ginfo(gid_)%device_alloc(vars_id+comm_vsize_max) = .true.
857  ginfo(gid_)%device_ptr(vars_id+comm_vsize_max)%ptr => var
858  !$acc enter data copyin(var)
859  end if
860 #endif
861 
862  call vars8_init_mpi_pc(var, gid_, vars_id, vid)
863 
864  vid = vars_id + comm_vsize_max
865 
866  log_info("COMM_vars8_init",'(1x,A,I3.3,A,I3.3,2A)') 'Initialize variable (grid ID = ', gid_, '): ID = ', vid, &
867  ', name = ', trim(varname)
868 
869  call prof_rapend ('COMM_init_pers', 2)
870 
871  return
872  end subroutine comm_vars8_init
873 
874  !-----------------------------------------------------------------------------
875  subroutine comm_vars_3d(var, vid, gid)
876  use scale_prc, only: &
877  prc_abort
878  implicit none
879 
880  real(RP), intent(inout) :: var(:,:,:)
881 
882  integer, intent(in) :: vid
883 
884  integer, intent(in), optional :: gid
885 
886  integer :: gid_
887  !---------------------------------------------------------------------------
888 
889  gid_ = 1
890  if ( present(gid) ) gid_ = gid
891  if ( gid_ > comm_gid_max ) then
892  log_error("COMM_vars_3D",*) 'gid is invalid', gid_, comm_gid_max
893  call prc_abort
894  end if
895 
896  if ( vid > comm_vsize_max ) then
897  call prof_rapstart('COMM_vars_pers', 2)
898  call vars_3d_mpi_pc(var, gid_, vid-comm_vsize_max)
899  call prof_rapend ('COMM_vars_pers', 2)
900  else
901  call prof_rapstart('COMM_vars', 2)
902  if ( comm_use_mpi_onesided ) then
903  call vars_3d_mpi_onesided(var, gid_, vid)
904  else
905  call vars_3d_mpi(var, gid_, vid)
906  end if
907  call prof_rapend ('COMM_vars', 2)
908  end if
909 
910  return
911  end subroutine comm_vars_3d
912 
913  !-----------------------------------------------------------------------------
914  subroutine comm_vars8_3d(var, vid, gid)
915  use scale_prc, only: &
916  prc_abort
917  implicit none
918 
919  real(RP), intent(inout) :: var(:,:,:)
920 
921  integer, intent(in) :: vid
922 
923  integer, intent(in), optional :: gid
924 
925  integer :: gid_
926  !---------------------------------------------------------------------------
927 
928  gid_ = 1
929  if ( present(gid) ) gid_ = gid
930  if ( gid_ > comm_gid_max ) then
931  log_error("COMM_vars8_3D",*) 'gid is invalid', gid_, comm_gid_max
932  call prc_abort
933  end if
934 
935  if ( vid > comm_vsize_max ) then
936  call prof_rapstart('COMM_vars_pers', 2)
937  call vars_3d_mpi_pc(var, gid_, vid-comm_vsize_max)
938  call prof_rapend ('COMM_vars_pers', 2)
939  else
940  call prof_rapstart('COMM_vars', 2)
941  if ( comm_use_mpi_onesided ) then
942  call vars8_3d_mpi_onesided(var, gid_, vid)
943  else
944  call vars8_3d_mpi(var, gid_, vid)
945  end if
946  call prof_rapend ('COMM_vars', 2)
947  end if
948 
949  return
950  end subroutine comm_vars8_3d
951 
952  !-----------------------------------------------------------------------------
953  subroutine comm_wait_3d(var, vid, FILL_BND, gid)
954  use scale_prc, only: &
955  prc_abort
956  implicit none
957 
958  real(RP), intent(inout) :: var(:,:,:)
959 
960  integer, intent(in) :: vid
961 
962  logical, intent(in), optional :: FILL_BND
963  integer, intent(in), optional :: gid
964 
965  logical :: FILL_BND_
966  integer :: gid_
967  !---------------------------------------------------------------------------
968 
969  fill_bnd_ = .true.
970  if ( present(fill_bnd) ) fill_bnd_ = fill_bnd
971 
972  gid_ = 1
973  if ( present(gid) ) gid_ = gid
974  if ( gid_ > comm_gid_max ) then
975  log_error("COMM_wait_3D",*) 'gid is invalid', gid_, comm_gid_max
976  call prc_abort
977  end if
978 
979  if ( vid > comm_vsize_max ) then
980  call prof_rapstart('COMM_wait_pers', 2)
981  call wait_3d_mpi_pc(var, gid_, vid-comm_vsize_max)
982  call prof_rapend ('COMM_wait_pers', 2)
983  else
984  call prof_rapstart('COMM_wait', 2)
985  if ( comm_use_mpi_onesided ) then
986  call wait_3d_mpi_onesided(var, gid_, vid)
987  else
988  call wait_3d_mpi(var, gid_, vid)
989  end if
990  call prof_rapend ('COMM_wait', 2)
991  end if
992 
993  ! copy inner data to boundary
994  if ( .NOT. comm_isallperiodic ) then
995  if ( fill_bnd_ ) then
996  call copy_boundary_3d(var, gid_)
997  end if
998  end if
999 
1000  return
1001  end subroutine comm_wait_3d
1002 
1003  !-----------------------------------------------------------------------------
1004  subroutine comm_vars_2d(var, vid, gid)
1005  use scale_prc, only: &
1006  prc_abort
1007  implicit none
1008 
1009  real(RP), intent(inout) :: var(:,:)
1010 
1011  integer, intent(in) :: vid
1012 
1013  integer, intent(in), optional :: gid
1014 
1015  integer :: gid_
1016  !---------------------------------------------------------------------------
1017 
1018  gid_ = 1
1019  if ( present(gid) ) gid_ = gid
1020  if ( gid_ > comm_gid_max ) then
1021  log_error("COMM_vars_2D",*) 'gid is invalid', gid_, comm_gid_max
1022  call prc_abort
1023  end if
1024 
1025  call prof_rapstart('COMM_vars', 2)
1026  if ( comm_use_mpi_onesided ) then
1027  call vars_2d_mpi_onesided(var, gid_, vid)
1028  else
1029  call vars_2d_mpi(var, gid_, vid)
1030  end if
1031  call prof_rapend ('COMM_vars', 2)
1032 
1033  return
1034  end subroutine comm_vars_2d
1035 
1036  !-----------------------------------------------------------------------------
1037  subroutine comm_vars8_2d(var, vid, gid)
1038  use scale_prc, only: &
1039  prc_abort
1040  implicit none
1041 
1042  real(RP), intent(inout) :: var(:,:)
1043 
1044  integer, intent(in) :: vid
1045 
1046  integer, intent(in), optional :: gid
1047 
1048  integer :: gid_
1049  !---------------------------------------------------------------------------
1050 
1051  gid_ = 1
1052  if ( present(gid) ) gid_ = gid
1053  if ( gid_ > comm_gid_max ) then
1054  log_error("COMM_vars8_2D",*) 'gid is invalid', gid_, comm_gid_max
1055  call prc_abort
1056  end if
1057 
1058  call prof_rapstart('COMM_vars', 2)
1059  if ( comm_use_mpi_onesided ) then
1060  call vars8_2d_mpi_onesided(var, gid_, vid)
1061  else
1062  call vars8_2d_mpi(var, gid_, vid)
1063  end if
1064  call prof_rapend ('COMM_vars', 2)
1065 
1066  return
1067  end subroutine comm_vars8_2d
1068 
1069  !-----------------------------------------------------------------------------
1070  subroutine comm_wait_2d(var, vid, FILL_BND, gid)
1071  use scale_prc, only: &
1072  prc_abort
1073  implicit none
1074 
1075  real(RP), intent(inout) :: var(:,:)
1076 
1077  integer, intent(in) :: vid
1078 
1079  logical, intent(in), optional :: FILL_BND
1080  integer, intent(in), optional :: gid
1081 
1082  logical :: FILL_BND_
1083  integer :: gid_
1084  !---------------------------------------------------------------------------
1085 
1086  fill_bnd_ = .true.
1087  if ( present(fill_bnd) ) fill_bnd_ = fill_bnd
1088 
1089  gid_ = 1
1090  if ( present(gid) ) gid_ = gid
1091  if ( gid_ > comm_gid_max ) then
1092  log_error("COMM_wait_2D",*) 'gid is invalid', gid_, comm_gid_max
1093  call prc_abort
1094  end if
1095 
1096  call prof_rapstart('COMM_wait', 2)
1097  if ( comm_use_mpi_onesided ) then
1098  call wait_2d_mpi_onesided(var, gid_, vid)
1099  else
1100  call wait_2d_mpi(var, gid_, vid)
1101  end if
1102  call prof_rapend ('COMM_wait', 2)
1103 
1104  if( .NOT. comm_isallperiodic ) then
1105  if ( fill_bnd_ ) then
1106  call copy_boundary_2d(var, gid_)
1107  end if
1108  end if
1109 
1110  return
1111  end subroutine comm_wait_2d
1112 
1113  !-----------------------------------------------------------------------------
1115  subroutine comm_horizontal_mean_2d( &
1116  IA, IS, IE, JA, JS, JE, &
1117  var, &
1118  varmean )
1119  use scale_const, only: &
1120  const_undef
1121  implicit none
1122 
1123  integer, intent(in) :: IA, IS, IE
1124  integer, intent(in) :: JA, JS, JE
1125  real(RP), intent(in) :: var(IA,JA)
1126 
1127  real(RP), intent(out) :: varmean
1128 
1129  real(DP) :: stat(2)
1130  real(DP) :: stat1, stat2
1131  real(DP) :: allstat(2)
1132  real(DP) :: zerosw
1133 
1134  integer :: ierr
1135  integer :: i, j
1136  !---------------------------------------------------------------------------
1137 
1138  stat1 = 0.0_dp
1139  stat2 = 0.0_dp
1140  !$omp parallel do reduction(+:stat1,stat2)
1141  !$acc kernels if(acc_is_present(var))
1142  !$acc loop reduction(+:stat1,stat2)
1143  do j = js, je
1144  !$acc loop reduction(+:stat1,stat2)
1145  do i = is, ie
1146  if ( abs(var(i,j)) < abs(const_undef) ) then
1147  stat1 = stat1 + var(i,j)
1148  stat2 = stat2 + 1.0_dp
1149  endif
1150  enddo
1151  enddo
1152  !$acc end kernels
1153 
1154  stat(:) = (/stat1, stat2/)
1155 
1156  ! All reduce
1157  ! [NOTE] always communicate globally
1158  call prof_rapstart('COMM_Allreduce', 2)
1159  call mpi_allreduce( stat, &
1160  allstat, &
1161  2, &
1162  mpi_double_precision, &
1163  mpi_sum, &
1164  comm_world_t, &
1165  ierr )
1166  call prof_rapend ('COMM_Allreduce', 2)
1167 
1168  zerosw = 0.5_dp - sign(0.5_dp, allstat(1) - 1.e-12_dp )
1169  varmean = allstat(1) / ( allstat(2) + zerosw ) * ( 1.0_dp - zerosw )
1170  !LOG_INFO("COMM_horizontal_mean_2D",*) varmean, allstat(1), allstat(2)
1171 
1172  return
1173  end subroutine comm_horizontal_mean_2d
1174 
1175  !-----------------------------------------------------------------------------
1177  subroutine comm_horizontal_mean_3d( &
1178  KA, IA, IS, IE, JA, JS, JE, &
1179  var, &
1180  varmean )
1181  use scale_const, only: &
1182  const_undef
1183  implicit none
1184 
1185  integer, intent(in) :: KA
1186  integer, intent(in) :: IA, IS, IE
1187  integer, intent(in) :: JA, JS, JE
1188  real(RP), intent(in) :: var(KA,IA,JA)
1189 
1190  real(RP), intent(out) :: varmean(KA)
1191 
1192  real(DP) :: stat (KA,2)
1193  real(DP) :: allstat(KA,2)
1194  real(DP) :: zerosw
1195 
1196  integer :: ierr
1197  integer :: k, i, j
1198 #ifdef _OPENACC
1199  logical :: flag_device
1200 #endif
1201  !---------------------------------------------------------------------------
1202 
1203 #ifdef _OPENACC
1204  flag_device = acc_is_present(var)
1205 #endif
1206 
1207  !$acc data create(stat, allstat) if(flag_device)
1208 
1209  !$acc kernels if(flag_device)
1210  stat(:,:) = 0.0_dp
1211  !$acc end kernels
1212  !$acc kernels if(flag_device)
1213  !$acc loop independent
1214  do j = js, je
1215  !$acc loop independent
1216  do i = is, ie
1217  do k = 1, ka
1218  if ( abs(var(k,i,j)) < abs(const_undef) ) then
1219  !$acc atomic update
1220  stat(k,1) = stat(k,1) + var(k,i,j)
1221  !$acc end atomic
1222  !$acc atomic update
1223  stat(k,2) = stat(k,2) + 1.0_dp
1224  !$acc end atomic
1225  endif
1226  enddo
1227  enddo
1228  enddo
1229  !$acc end kernels
1230 
1231 
1232  ! All reduce
1233  ! [NOTE] always communicate globally
1234  call prof_rapstart('COMM_Allreduce', 2)
1235  !$acc host_data use_device(stat, allstat) if(flag_device)
1236  call mpi_allreduce( stat, &
1237  allstat, &
1238  ka * 2, &
1239  mpi_double_precision, &
1240  mpi_sum, &
1241  comm_world_t, &
1242  ierr )
1243  !$acc end host_data
1244  call prof_rapend ('COMM_Allreduce', 2)
1245 
1246  !$acc kernels if(flag_device)
1247  do k = 1, ka
1248  zerosw = 0.5_dp - sign(0.5_dp, allstat(k,2) - 1.e-12_dp )
1249  varmean(k) = allstat(k,1) / ( allstat(k,2) + zerosw ) * ( 1.0_dp - zerosw )
1250  !LOG_INFO("COMM_horizontal_mean_3D",*) k, varmean(k), allstatval(k), allstatcnt(k)
1251  enddo
1252  !$acc end kernels
1253 
1254  !$acc end data
1255 
1256  return
1257  end subroutine comm_horizontal_mean_3d
1258 
1259  !-----------------------------------------------------------------------------
1261  subroutine comm_gather_2d( &
1262  IA, JA, &
1263  send, &
1264  recv )
1265  use scale_prc, only: &
1266  prc_masterrank
1267  implicit none
1268 
1269  integer, intent(in) :: IA, JA
1270  real(RP), intent(in) :: send(IA,JA)
1271 
1272  real(RP), intent(out) :: recv(:,:,:)
1273 
1274  integer :: sendcounts, recvcounts
1275  integer :: ierr
1276  !---------------------------------------------------------------------------
1277 
1278  sendcounts = ia * ja
1279  recvcounts = ia * ja
1280 
1281  !$acc host_data use_device(send, recv) if(acc_is_present(send))
1282  call mpi_gather( send(:,:), &
1283  sendcounts, &
1284  comm_datatype_t, &
1285  recv(:,:,:), &
1286  recvcounts, &
1287  comm_datatype_t, &
1288  prc_masterrank, &
1289  comm_world_t, &
1290  ierr )
1291  !$acc end host_data
1292 
1293  return
1294  end subroutine comm_gather_2d
1295 
1296  !-----------------------------------------------------------------------------
1298  subroutine comm_gather_3d( &
1299  KA, IA, JA, &
1300  send, &
1301  recv )
1302  use scale_prc, only: &
1303  prc_masterrank
1304  implicit none
1305 
1306  integer, intent(in) :: KA, IA, JA
1307  real(RP), intent(in) :: send(KA,IA,JA)
1308 
1309  real(RP), intent(out) :: recv(:,:,:,:)
1310 
1311  integer :: sendcounts, recvcounts
1312  integer :: ierr
1313  !---------------------------------------------------------------------------
1314 
1315  sendcounts = ka * ia * ja
1316  recvcounts = ka * ia * ja
1317 
1318  !$acc host_data use_device(send, recv) if(acc_is_present(send))
1319  call mpi_gather( send(:,:,:), &
1320  sendcounts, &
1321  comm_datatype_t, &
1322  recv(:,:,:,:), &
1323  recvcounts, &
1324  comm_datatype_t, &
1325  prc_masterrank, &
1326  comm_world_t, &
1327  ierr )
1328  !$acc end host_data
1329 
1330  return
1331  end subroutine comm_gather_3d
1332 
1333  !-----------------------------------------------------------------------------
1335  subroutine comm_bcast_scr_sp( var )
1336  use scale_prc, only: &
1337  prc_masterrank
1338  implicit none
1339 
1340  real(SP), intent(inout) :: var
1341 
1342  integer :: counts
1343  integer :: ierr
1344  !---------------------------------------------------------------------------
1345 
1346  call prof_rapstart('COMM_Bcast', 2)
1347 
1348  counts = 1
1349 
1350  call mpi_bcast( var, &
1351  counts, &
1352  mpi_real, &
1353  prc_masterrank, &
1354  comm_world_t, &
1355  ierr )
1356 
1357  call prof_rapend('COMM_Bcast', 2)
1358 
1359  return
1360  end subroutine comm_bcast_scr_sp
1361  subroutine comm_bcast_scr_dp( var )
1362  use scale_prc, only: &
1363  prc_masterrank
1364  implicit none
1365 
1366  real(DP), intent(inout) :: var
1367 
1368  integer :: counts
1369  integer :: ierr
1370  !---------------------------------------------------------------------------
1371 
1372  call prof_rapstart('COMM_Bcast', 2)
1373 
1374  counts = 1
1375 
1376  call mpi_bcast( var, &
1377  counts, &
1378  mpi_double_precision, &
1379  prc_masterrank, &
1380  comm_world_t, &
1381  ierr )
1382 
1383  call prof_rapend('COMM_Bcast', 2)
1384 
1385  return
1386  end subroutine comm_bcast_scr_dp
1387 
1388  !-----------------------------------------------------------------------------
1390  subroutine comm_bcast_1d_sp( IA, var )
1391  use scale_prc, only: &
1392  prc_masterrank
1393  implicit none
1394 
1395  integer, intent(in) :: IA
1396 
1397  real(SP), intent(inout) :: var(IA)
1398 
1399  integer :: counts
1400  integer :: ierr
1401  !---------------------------------------------------------------------------
1402 
1403  call prof_rapstart('COMM_Bcast', 2)
1404 
1405  counts = ia
1406 
1407  !$acc host_data use_device(var) if(acc_is_present(var))
1408  call mpi_bcast( var(:), &
1409  counts, &
1410  mpi_real, &
1411  prc_masterrank, &
1412  comm_world_t, &
1413  ierr )
1414  !$acc end host_data
1415 
1416  call prof_rapend('COMM_Bcast', 2)
1417 
1418  return
1419  end subroutine comm_bcast_1d_sp
1420  subroutine comm_bcast_1d_dp( IA, var )
1421  use scale_prc, only: &
1422  prc_masterrank
1423  implicit none
1424 
1425  integer, intent(in) :: IA
1426 
1427  real(DP), intent(inout) :: var(IA)
1428 
1429  integer :: counts
1430  integer :: ierr
1431  !---------------------------------------------------------------------------
1432 
1433  call prof_rapstart('COMM_Bcast', 2)
1434 
1435  counts = ia
1436 
1437  !$acc host_data use_device(var) if(acc_is_present(var))
1438  call mpi_bcast( var(:), &
1439  counts, &
1440  mpi_double_precision, &
1441  prc_masterrank, &
1442  comm_world_t, &
1443  ierr )
1444  !$acc end host_data
1445 
1446  call prof_rapend('COMM_Bcast', 2)
1447 
1448  return
1449  end subroutine comm_bcast_1d_dp
1450 
1451  !-----------------------------------------------------------------------------
1453  subroutine comm_bcast_2d_sp( IA, JA, var )
1454  use scale_prc, only: &
1455  prc_masterrank
1456  implicit none
1457 
1458  integer, intent(in) :: IA, JA
1459 
1460  real(SP), intent(inout) :: var(IA,JA)
1461 
1462  integer :: counts
1463  integer :: ierr
1464  !---------------------------------------------------------------------------
1465 
1466  call prof_rapstart('COMM_Bcast', 2)
1467 
1468  counts = ia * ja
1469 
1470  !$acc host_data use_device(var) if(acc_is_present(var))
1471  call mpi_bcast( var(:,:), &
1472  counts, &
1473  mpi_real, &
1474  prc_masterrank, &
1475  comm_world_t, &
1476  ierr )
1477  !$acc end host_data
1478 
1479  call prof_rapend('COMM_Bcast', 2)
1480 
1481  return
1482  end subroutine comm_bcast_2d_sp
1483  subroutine comm_bcast_2d_dp( IA, JA, var )
1484  use scale_prc, only: &
1485  prc_masterrank
1486  implicit none
1487 
1488  integer, intent(in) :: IA, JA
1489 
1490  real(DP), intent(inout) :: var(IA,JA)
1491 
1492  integer :: counts
1493  integer :: ierr
1494  !---------------------------------------------------------------------------
1495 
1496  call prof_rapstart('COMM_Bcast', 2)
1497 
1498  counts = ia * ja
1499 
1500  !$acc host_data use_device(var) if(acc_is_present(var))
1501  call mpi_bcast( var(:,:), &
1502  counts, &
1503  mpi_double_precision, &
1504  prc_masterrank, &
1505  comm_world_t, &
1506  ierr )
1507  !$acc end host_data
1508 
1509  call prof_rapend('COMM_Bcast', 2)
1510 
1511  return
1512  end subroutine comm_bcast_2d_dp
1513 
1514  !-----------------------------------------------------------------------------
1516  subroutine comm_bcast_3d_sp( KA, IA, JA, var )
1517  use scale_prc, only: &
1518  prc_masterrank
1519  implicit none
1520 
1521  integer, intent(in) :: KA, IA, JA
1522 
1523  real(SP), intent(inout) :: var(KA,IA,JA)
1524 
1525  integer :: counts
1526  integer :: ierr
1527  !---------------------------------------------------------------------------
1528 
1529  call prof_rapstart('COMM_Bcast', 2)
1530 
1531  counts = ka * ia * ja
1532 
1533  !$acc host_data use_device(var) if(acc_is_present(var))
1534  call mpi_bcast( var(:,:,:), &
1535  counts, &
1536  mpi_real, &
1537  prc_masterrank, &
1538  comm_world_t, &
1539  ierr )
1540  !$acc end host_data
1541 
1542  call prof_rapend('COMM_Bcast', 2)
1543 
1544  return
1545  end subroutine comm_bcast_3d_sp
1546  subroutine comm_bcast_3d_dp( KA, IA, JA, var )
1547  use scale_prc, only: &
1548  prc_masterrank
1549  implicit none
1550 
1551  integer, intent(in) :: KA, IA, JA
1552 
1553  real(DP), intent(inout) :: var(KA,IA,JA)
1554 
1555  integer :: counts
1556  integer :: ierr
1557  !---------------------------------------------------------------------------
1558 
1559  call prof_rapstart('COMM_Bcast', 2)
1560 
1561  counts = ka * ia * ja
1562 
1563  !$acc host_data use_device(var) if(acc_is_present(var))
1564  call mpi_bcast( var(:,:,:), &
1565  counts, &
1566  mpi_double_precision, &
1567  prc_masterrank, &
1568  comm_world_t, &
1569  ierr )
1570  !$acc end host_data
1571 
1572  call prof_rapend('COMM_Bcast', 2)
1573 
1574  return
1575  end subroutine comm_bcast_3d_dp
1576 
1577  !-----------------------------------------------------------------------------
1579  subroutine comm_bcast_4d_sp( KA, IA, JA, NT, var )
1580  use scale_prc, only: &
1581  prc_abort, &
1582  prc_masterrank
1583  implicit none
1584 
1585  integer, intent(in) :: KA, IA, JA, NT
1586 
1587  real(SP), intent(inout) :: var(KA,IA,JA,NT)
1588 
1589  integer :: counts
1590  integer :: ierr
1591  !---------------------------------------------------------------------------
1592 
1593  call prof_rapstart('COMM_Bcast', 2)
1594 
1595  counts = ka * ia * ja * nt
1596  if ( ka>0 .AND. ia>0 .AND. ja>0 .AND. nt>0 .AND. &
1597  counts < 0 ) then
1598  log_error("COMM_bcast_4D",*) 'counts overflow'
1599  call prc_abort
1600  end if
1601 
1602  !$acc host_data use_device(var) if(acc_is_present(var))
1603  call mpi_bcast( var(:,:,:,:), &
1604  counts, &
1605  mpi_real, &
1606  prc_masterrank, &
1607  comm_world_t, &
1608  ierr )
1609  !$acc end host_data
1610 
1611  call prof_rapend('COMM_Bcast', 2)
1612 
1613  return
1614  end subroutine comm_bcast_4d_sp
1615  subroutine comm_bcast_4d_dp( KA, IA, JA, NT, var )
1616  use scale_prc, only: &
1617  prc_abort, &
1618  prc_masterrank
1619  implicit none
1620 
1621  integer, intent(in) :: KA, IA, JA, NT
1622 
1623  real(DP), intent(inout) :: var(KA,IA,JA,NT)
1624 
1625  integer :: counts
1626  integer :: ierr
1627  !---------------------------------------------------------------------------
1628 
1629  call prof_rapstart('COMM_Bcast', 2)
1630 
1631  counts = ka * ia * ja * nt
1632  if ( ka>0 .AND. ia>0 .AND. ja>0 .AND. nt>0 .AND. &
1633  counts < 0 ) then
1634  log_error("COMM_bcast_4D",*) 'counts overflow'
1635  call prc_abort
1636  end if
1637 
1638  !$acc host_data use_device(var) if(acc_is_present(var))
1639  call mpi_bcast( var(:,:,:,:), &
1640  counts, &
1641  mpi_double_precision, &
1642  prc_masterrank, &
1643  comm_world_t, &
1644  ierr )
1645  !$acc end host_data
1646 
1647  call prof_rapend('COMM_Bcast', 2)
1648 
1649  return
1650  end subroutine comm_bcast_4d_dp
1651 
1652  !-----------------------------------------------------------------------------
1654  subroutine comm_bcast_int_scr( var )
1655  use scale_prc, only: &
1656  prc_masterrank
1657  implicit none
1658 
1659  integer, intent(inout) :: var
1660 
1661  integer :: counts
1662  integer :: ierr
1663  !---------------------------------------------------------------------------
1664 
1665  call prof_rapstart('COMM_Bcast', 2)
1666 
1667  counts = 1
1668 
1669  call mpi_bcast( var, &
1670  counts, &
1671  mpi_integer, &
1672  prc_masterrank, &
1673  comm_world_t, &
1674  ierr )
1675 
1676  call prof_rapend('COMM_Bcast', 2)
1677 
1678  return
1679  end subroutine comm_bcast_int_scr
1680 
1681  !-----------------------------------------------------------------------------
1683  subroutine comm_bcast_int_1d( IA, var )
1684  use scale_prc, only: &
1685  prc_masterrank
1686  implicit none
1687 
1688  integer, intent(in) :: IA
1689  integer, intent(inout) :: var(IA)
1690 
1691  integer :: counts
1692  integer :: ierr
1693  !---------------------------------------------------------------------------
1694 
1695  call prof_rapstart('COMM_Bcast', 2)
1696 
1697  counts = ia
1698 
1699  call mpi_bcast( var(:), &
1700  counts, &
1701  mpi_integer, &
1702  prc_masterrank, &
1703  comm_world_t, &
1704  ierr )
1705 
1706  call prof_rapend('COMM_Bcast', 2)
1707 
1708  return
1709  end subroutine comm_bcast_int_1d
1710 
1711  !-----------------------------------------------------------------------------
1713  subroutine comm_bcast_int_2d( IA, JA, var )
1714  use scale_prc, only: &
1715  prc_masterrank
1716  implicit none
1717 
1718  integer, intent(in) :: IA, JA
1719 
1720  integer, intent(inout) :: var(IA,JA)
1721 
1722  integer :: counts
1723  integer :: ierr
1724  !---------------------------------------------------------------------------
1725 
1726  call prof_rapstart('COMM_Bcast', 2)
1727 
1728  counts = ia * ja
1729 
1730  !$acc host_data use_device(var) if(acc_is_present(var))
1731  call mpi_bcast( var(:,:), &
1732  counts, &
1733  mpi_integer, &
1734  prc_masterrank, &
1735  comm_world_t, &
1736  ierr )
1737  !$acc end host_data
1738 
1739  call prof_rapend('COMM_Bcast', 2)
1740 
1741  return
1742  end subroutine comm_bcast_int_2d
1743 
1744  !-----------------------------------------------------------------------------
1746  subroutine comm_bcast_logical_scr( var )
1747  use scale_prc, only: &
1748  prc_masterrank
1749  implicit none
1750 
1751  logical, intent(inout) :: var
1752 
1753  integer :: counts
1754  integer :: ierr
1755  !---------------------------------------------------------------------------
1756 
1757  call prof_rapstart('COMM_Bcast', 2)
1758 
1759  counts = 1
1760 
1761  call mpi_bcast( var, &
1762  counts, &
1763  mpi_logical, &
1764  prc_masterrank, &
1765  comm_world_t, &
1766  ierr )
1767 
1768  call prof_rapend('COMM_Bcast', 2)
1769 
1770  return
1771  end subroutine comm_bcast_logical_scr
1772 
1773  !-----------------------------------------------------------------------------
1775  subroutine comm_bcast_logical_1d( IA, var )
1776  use scale_prc, only: &
1777  prc_masterrank
1778  implicit none
1779 
1780  integer, intent(in) :: IA
1781  logical, intent(inout) :: var(IA)
1782 
1783  integer :: counts
1784  integer :: ierr
1785  !---------------------------------------------------------------------------
1786 
1787  call prof_rapstart('COMM_Bcast', 2)
1788 
1789  counts = ia
1790 
1791  !$acc host_data use_device(var) if(acc_is_present(var))
1792  call mpi_bcast( var(:), &
1793  counts, &
1794  mpi_logical, &
1795  prc_masterrank, &
1796  comm_world_t, &
1797  ierr )
1798  !$acc end host_data
1799 
1800  call prof_rapend('COMM_Bcast', 2)
1801 
1802  return
1803  end subroutine comm_bcast_logical_1d
1804 
1805  !-----------------------------------------------------------------------------
1807  subroutine comm_bcast_character( var )
1808  use scale_prc, only: &
1809  prc_masterrank
1810  implicit none
1811 
1812  character(len=*), intent(inout) :: var
1813 
1814  integer :: counts
1815  integer :: ierr
1816  !---------------------------------------------------------------------------
1817 
1818  call prof_rapstart('COMM_Bcast', 2)
1819 
1820  counts = len(var)
1821 
1822  call mpi_bcast( var, &
1823  counts, &
1824  mpi_character, &
1825  prc_masterrank, &
1826  comm_world_t, &
1827  ierr )
1828 
1829  call prof_rapend('COMM_Bcast', 2)
1830 
1831  return
1832  end subroutine comm_bcast_character
1833 
1834 !-------------------------------------------------------------------------------
1835 ! private routines
1836 !-------------------------------------------------------------------------------
1837  subroutine vars_init_mpi_pc(var, gid, vid, seqid)
1838  use scale_prc_cartesc, only: &
1839  prc_twod
1840  implicit none
1841 
1842  real(RP), intent(inout) :: var(:,:,:)
1843  integer, intent(in) :: gid
1844  integer, intent(in) :: vid
1845  integer, intent(in) :: seqid
1846 
1847  integer :: ireq, tag, ierr
1848  logical :: flag
1849 
1850  integer :: KA
1851  integer :: JA, JS, JE, JHALO
1852 
1853  integer :: nreq
1854  integer :: i
1855 
1856 #ifdef _OPENACC
1857  real(RP), pointer :: ptr(:,:)
1858 #endif
1859 
1860  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
1861  ireq = 1
1862 
1863  ka = ginfo(gid)%KA
1864  ja = ginfo(gid)%JA
1865  js = ginfo(gid)%JS
1866  je = ginfo(gid)%JE
1867  jhalo = ginfo(gid)%JHALO
1868 
1869  !$acc host_data use_device(var)
1870 
1871  ! register whole array to inner table of MPI and/or lower library
1872  ! otherwise a lot of sub small segments would be registered
1873  call mpi_send_init( var(:,:,:), size(var), comm_datatype_t, &
1874  mpi_proc_null, tag+ginfo(gid)%nreq_max+1, comm_world_t, &
1875  ginfo(gid)%preq_list(ginfo(gid)%nreq_max+1,vid), ierr )
1876 
1877  !--- From 4-Direction HALO communicate
1878  ! From S
1879  if ( prc_has_s ) then
1880  call mpi_recv_init( var(:,:,1:js-1), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
1881  prc_next(prc_s), tag+1, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1882  ireq = ireq + 1
1883  end if
1884  ! From N
1885  if ( prc_has_n ) then
1886  call mpi_recv_init( var(:,:,je+1:ja), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
1887  prc_next(prc_n), tag+2, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1888  ireq = ireq + 1
1889  end if
1890  if ( .not. prc_twod ) then
1891 #ifdef _OPENACC
1892  ptr => ginfo(gid)%recvpack_WE2P(:,:,seqid)
1893  !$acc host_data use_device(ptr)
1894 #endif
1895 
1896  ! From E
1897  if ( prc_has_e ) then
1898 #ifdef _OPENACC
1899  call mpi_recv_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1900 #else
1901  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1902 #endif
1903  prc_next(prc_e), tag+3, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1904  ireq = ireq + 1
1905  end if
1906  ! From W
1907  if ( prc_has_w ) then
1908 #ifdef _OPENACC
1909  call mpi_recv_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1910 #else
1911  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1912 #endif
1913  prc_next(prc_w), tag+4, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1914  ireq = ireq + 1
1915  end if
1916  !$acc end host_data
1917  end if
1918 
1919  !--- To 4-Direction HALO communicate
1920  if ( .not. prc_twod ) then
1921 #ifdef _OPENACC
1922  ptr => ginfo(gid)%sendpack_P2WE(:,:,seqid)
1923  !$acc host_data use_device(ptr)
1924 #endif
1925  ! To W HALO
1926  if ( prc_has_w ) then
1927 #ifdef _OPENACC
1928  call mpi_send_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1929 #else
1930  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1931 #endif
1932  prc_next(prc_w), tag+3, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1933  ireq = ireq + 1
1934  end if
1935  ! To E HALO
1936  if ( prc_has_e ) then
1937 #ifdef _OPENACC
1938  call mpi_send_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1939 #else
1940  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1941 #endif
1942  prc_next(prc_e), tag+4, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1943  ireq = ireq + 1
1944  end if
1945  !$acc end host_data
1946  end if
1947  ! To N HALO
1948  if ( prc_has_n ) then
1949  call mpi_send_init( var(:,:,je-jhalo+1:je), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
1950  prc_next(prc_n), tag+1, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1951  ireq = ireq + 1
1952  end if
1953  ! To S HALO
1954  if ( prc_has_s ) then
1955  call mpi_send_init( var(:,:,js:js+jhalo-1), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
1956  prc_next(prc_s), tag+2, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1957  ireq = ireq + 1
1958  end if
1959 
1960  ginfo(gid)%preq_cnt(vid) = ireq - 1
1961 
1962  ! to finish initial processes of MPI
1963  nreq = ginfo(gid)%preq_cnt(vid)
1964  do i = 1, 32
1965  call mpi_testall( nreq, ginfo(gid)%preq_list(1:nreq,vid), &
1966  flag, mpi_statuses_ignore, ierr )
1967  enddo
1968 
1969  !$acc end host_data
1970 
1971  return
1972  end subroutine vars_init_mpi_pc
1973 
1974  subroutine vars8_init_mpi_pc(var, gid, vid, seqid)
1975  use scale_prc_cartesc, only: &
1976  prc_twod
1977  implicit none
1978 
1979  real(RP), intent(inout) :: var(:,:,:)
1980  integer, intent(in) :: gid
1981  integer, intent(in) :: vid
1982  integer, intent(in) :: seqid
1983 
1984  integer :: ireq, tag, tagc
1985  integer :: ierr
1986  logical :: flag
1987 
1988  integer :: KA
1989  integer :: IS, IE, IHALO
1990  integer :: JA, JS, JE, JHALO
1991 
1992  integer :: nreq
1993  integer :: i, j
1994 
1995 #ifdef _OPENACC
1996  real(RP), pointer :: ptr(:,:)
1997 #endif
1998 
1999  ka = ginfo(gid)%KA
2000  is = ginfo(gid)%IS
2001  ie = ginfo(gid)%IE
2002  ihalo = ginfo(gid)%IHALO
2003  ja = ginfo(gid)%JA
2004  js = ginfo(gid)%JS
2005  je = ginfo(gid)%JE
2006  jhalo = ginfo(gid)%JHALO
2007 
2008  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
2009  ireq = 1
2010 
2011  !$acc host_data use_device(var)
2012 
2013  ! register whole array to inner table of MPI and/or lower library
2014  ! otherwise a lot of sub small segments would be registered
2015  call mpi_send_init( var(:,:,:), size(var), comm_datatype_t, &
2016  mpi_proc_null, tag+ginfo(gid)%nreq_max+1, comm_world_t, &
2017  ginfo(gid)%preq_list(ginfo(gid)%nreq_max+1,vid), ierr )
2018 
2019 
2020  if ( comm_isallperiodic ) then ! periodic condition
2021 
2022  !--- From 8-Direction HALO communicate
2023  if ( .not. prc_twod ) then
2024  ! From SE
2025  tagc = 0
2026  do j = 1, js-1
2027  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2028  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2029  ireq = ireq + 1
2030  tagc = tagc + 1
2031  enddo
2032  ! From SW
2033  tagc = 10
2034  do j = 1, js-1
2035  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2036  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2037  ireq = ireq + 1
2038  tagc = tagc + 1
2039  enddo
2040  ! From NE
2041  tagc = 20
2042  do j = je+1, ja
2043  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2044  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2045  ireq = ireq + 1
2046  tagc = tagc + 1
2047  enddo
2048  ! From NW
2049  tagc = 30
2050  do j = je+1, je+jhalo
2051  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2052  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2053  ireq = ireq + 1
2054  tagc = tagc + 1
2055  enddo
2056  ! From E
2057  tagc = 60
2058 #ifdef _OPENACC
2059  ptr => ginfo(gid)%recvpack_WE2P(:,:,seqid)
2060  !$acc host_data use_device(ptr)
2061  call mpi_recv_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2062 #else
2063  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2064 #endif
2065  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2066  ireq = ireq + 1
2067  ! From W
2068  tagc = 70
2069 #ifdef _OPENACC
2070  call mpi_recv_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2071 #else
2072  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2073 #endif
2074  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2075  !$acc end host_data
2076  ireq = ireq + 1
2077  end if
2078  ! From S
2079  tagc = 40
2080  do j = 1, js-1
2081  call mpi_recv_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2082  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2083  ireq = ireq + 1
2084  tagc = tagc + 1
2085  enddo
2086  ! From N
2087  tagc = 50
2088  do j = je+1, ja
2089  call mpi_recv_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2090  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2091  ireq = ireq + 1
2092  tagc = tagc + 1
2093  enddo
2094 
2095  !--- To 8-Direction HALO communicate
2096  ! To N HALO
2097  tagc = 40
2098  do j = je-jhalo+1, je
2099  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2100  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2101  ireq = ireq + 1
2102  tagc = tagc + 1
2103  enddo
2104  ! To S HALO
2105  tagc = 50
2106  do j = js, js+jhalo-1
2107  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2108  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2109  ireq = ireq + 1
2110  tagc = tagc + 1
2111  enddo
2112  if ( .not. prc_twod ) then
2113  ! To W HALO
2114  tagc = 60
2115 #ifdef _OPENACC
2116  ptr => ginfo(gid)%sendpack_P2WE(:,:,seqid)
2117  !$acc host_data use_device(ptr)
2118  call mpi_send_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2119 #else
2120  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2121 #endif
2122  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2123  ireq = ireq + 1
2124  ! To E HALO
2125  tagc = 70
2126 #ifdef _OPENACC
2127  call mpi_send_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2128 #else
2129  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2130 #endif
2131  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2132  !$acc end host_data
2133  ireq = ireq + 1
2134  ! To NW HALO
2135  tagc = 0
2136  do j = je-jhalo+1, je
2137  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2138  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2139  ireq = ireq + 1
2140  tagc = tagc + 1
2141  enddo
2142  ! To NE HALO
2143  tagc = 10
2144  do j = je-jhalo+1, je
2145  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2146  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2147  ireq = ireq + 1
2148  tagc = tagc + 1
2149  enddo
2150  ! To SW HALO
2151  tagc = 20
2152  do j = js, js+jhalo-1
2153  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2154  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2155  ireq = ireq + 1
2156  tagc = tagc + 1
2157  enddo
2158  ! To SE HALO
2159  tagc = 30
2160  do j = js, js+jhalo-1
2161  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2162  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2163  ireq = ireq + 1
2164  tagc = tagc + 1
2165  enddo
2166  end if
2167 
2168  else ! non-periodic condition
2169 
2170  !--- From 8-Direction HALO communicate
2171  if ( .not. prc_twod ) then
2172  ! From SE
2173  if ( prc_has_s .AND. prc_has_e ) then
2174  tagc = 0
2175  do j = 1, js-1
2176  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2177  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2178  ireq = ireq + 1
2179  tagc = tagc + 1
2180  enddo
2181  else if ( prc_has_s ) then
2182  tagc = 0
2183  do j = 1, js-1
2184  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2185  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2186  ireq = ireq + 1
2187  tagc = tagc + 1
2188  enddo
2189  else if ( prc_has_e ) then
2190  tagc = 0
2191  do j = 1, js-1
2192  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2193  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2194  ireq = ireq + 1
2195  tagc = tagc + 1
2196  enddo
2197  endif
2198  ! From SW
2199  if ( prc_has_s .AND. prc_has_w ) then
2200  tagc = 10
2201  do j = 1, js-1
2202  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2203  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2204  ireq = ireq + 1
2205  tagc = tagc + 1
2206  enddo
2207  else if ( prc_has_s ) then
2208  tagc = 10
2209  do j = 1, js-1
2210  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2211  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2212  ireq = ireq + 1
2213  tagc = tagc + 1
2214  enddo
2215  else if ( prc_has_w ) then
2216  tagc = 10
2217  do j = 1, js-1
2218  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2219  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2220  ireq = ireq + 1
2221  tagc = tagc + 1
2222  enddo
2223  endif
2224  ! From NE
2225  if ( prc_has_n .AND. prc_has_e ) then
2226  tagc = 20
2227  do j = je+1, ja
2228  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2229  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2230  ireq = ireq + 1
2231  tagc = tagc + 1
2232  enddo
2233  else if ( prc_has_n ) then
2234  tagc = 20
2235  do j = je+1, ja
2236  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2237  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2238  ireq = ireq + 1
2239  tagc = tagc + 1
2240  enddo
2241  else if ( prc_has_e ) then
2242  tagc = 20
2243  do j = je+1, ja
2244  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2245  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2246  ireq = ireq + 1
2247  tagc = tagc + 1
2248  enddo
2249  endif
2250  ! From NW
2251  if ( prc_has_n .AND. prc_has_w ) then
2252  tagc = 30
2253  do j = je+1, ja
2254  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2255  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2256  ireq = ireq + 1
2257  tagc = tagc + 1
2258  enddo
2259  else if ( prc_has_n ) then
2260  tagc = 30
2261  do j = je+1, ja
2262  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2263  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2264  ireq = ireq + 1
2265  tagc = tagc + 1
2266  enddo
2267  else if ( prc_has_w ) then
2268  tagc = 30
2269  do j = je+1, ja
2270  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2271  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2272  ireq = ireq + 1
2273  tagc = tagc + 1
2274  enddo
2275  endif
2276 #ifdef _OPENACC
2277  ptr => ginfo(gid)%recvpack_WE2P(:,:,seqid)
2278  !$acc host_data use_device(ptr)
2279 #endif
2280  ! From E
2281  if ( prc_has_e ) then
2282  tagc = 60
2283 #ifdef _OPENACC
2284  call mpi_recv_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2285 #else
2286  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2287 #endif
2288  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2289  ireq = ireq + 1
2290  endif
2291  ! From W
2292  if ( prc_has_w ) then
2293  tagc = 70
2294 #ifdef _OPENACC
2295  call mpi_recv_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2296 #else
2297  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2298 #endif
2299  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2300  ireq = ireq + 1
2301  endif
2302  !$acc end host_data
2303  end if
2304  ! From S
2305  if ( prc_has_s ) then
2306  tagc = 40
2307  do j = 1, js-1
2308  call mpi_recv_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2309  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2310  ireq = ireq + 1
2311  tagc = tagc + 1
2312  enddo
2313  endif
2314  ! From N
2315  if ( prc_has_n ) then
2316  tagc = 50
2317  do j = je+1, ja
2318  call mpi_recv_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2319  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2320  ireq = ireq + 1
2321  tagc = tagc + 1
2322  enddo
2323  endif
2324 
2325  !--- To 8-Direction HALO communicate
2326  ! To N HALO
2327  if ( prc_has_n ) then
2328  tagc = 40
2329  do j = je-jhalo+1, je
2330  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2331  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2332  ireq = ireq + 1
2333  tagc = tagc + 1
2334  enddo
2335  endif
2336  ! To S HALO
2337  if ( prc_has_s ) then
2338  tagc = 50
2339  do j = js, js+jhalo-1
2340  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2341  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2342  ireq = ireq + 1
2343  tagc = tagc + 1
2344  enddo
2345  endif
2346  if ( .not. prc_twod ) then
2347 #ifdef _OPENACC
2348  ptr => ginfo(gid)%sendpack_P2WE(:,:,seqid)
2349  !$acc host_data use_device(ptr)
2350 #endif
2351  ! To W HALO
2352  if ( prc_has_w ) then
2353  tagc = 60
2354 #ifdef _OPENACC
2355  call mpi_send_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2356 #else
2357  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2358 #endif
2359  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2360  ireq = ireq + 1
2361  endif
2362  ! To E HALO
2363  if ( prc_has_e ) then
2364  tagc = 70
2365 #ifdef _OPENACC
2366  call mpi_send_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2367 #else
2368  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2369 #endif
2370  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2371  ireq = ireq + 1
2372  endif
2373  !$acc end host_data
2374  ! To NW HALO
2375  if ( prc_has_n .AND. prc_has_w ) then
2376  tagc = 0
2377  do j = je-jhalo+1, je
2378  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2379  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2380  ireq = ireq + 1
2381  tagc = tagc + 1
2382  enddo
2383  else if ( prc_has_n ) then
2384  tagc = 10
2385  do j = je-jhalo+1, je
2386  call mpi_send_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2387  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2388  ireq = ireq + 1
2389  tagc = tagc + 1
2390  enddo
2391  else if ( prc_has_w ) then
2392  tagc = 20
2393  do j = je+1, ja
2394  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2395  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2396  ireq = ireq + 1
2397  tagc = tagc + 1
2398  enddo
2399  endif
2400  ! To NE HALO
2401  if ( prc_has_n .AND. prc_has_e ) then
2402  tagc = 10
2403  do j = je-jhalo+1, je
2404  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2405  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2406  ireq = ireq + 1
2407  tagc = tagc + 1
2408  enddo
2409  else if ( prc_has_n ) then
2410  tagc = 0
2411  do j = je-jhalo+1, je
2412  call mpi_send_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2413  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2414  ireq = ireq + 1
2415  tagc = tagc + 1
2416  enddo
2417  else if ( prc_has_e ) then
2418  tagc = 30
2419  do j = je+1, ja
2420  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2421  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2422  ireq = ireq + 1
2423  tagc = tagc + 1
2424  enddo
2425  endif
2426  ! To SW HALO
2427  if ( prc_has_s .AND. prc_has_w ) then
2428  tagc = 20
2429  do j = js, js+jhalo-1
2430  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2431  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2432  ireq = ireq + 1
2433  tagc = tagc + 1
2434  enddo
2435  else if ( prc_has_s ) then
2436  tagc = 30
2437  do j = js, js+jhalo-1
2438  call mpi_send_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2439  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2440  ireq = ireq + 1
2441  tagc = tagc + 1
2442  enddo
2443  else if ( prc_has_w ) then
2444  tagc = 0
2445  do j = 1, js-1
2446  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2447  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2448  ireq = ireq + 1
2449  tagc = tagc + 1
2450  enddo
2451  endif
2452  ! To SE HALO
2453  if ( prc_has_s .AND. prc_has_e ) then
2454  tagc = 30
2455  do j = js, js+jhalo-1
2456  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2457  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2458  ireq = ireq + 1
2459  tagc = tagc + 1
2460  enddo
2461  else if ( prc_has_s ) then
2462  tagc = 20
2463  do j = js, js+jhalo-1
2464  call mpi_send_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2465  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2466  ireq = ireq + 1
2467  tagc = tagc + 1
2468  enddo
2469  else if ( prc_has_e ) then
2470  tagc = 10
2471  do j = 1, js-1
2472  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2473  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2474  ireq = ireq + 1
2475  tagc = tagc + 1
2476  enddo
2477  endif
2478  end if
2479 
2480  endif
2481 
2482  ginfo(gid)%preq_cnt(vid) = ireq - 1
2483 
2484  ! to finish initial processes of MPI
2485  nreq = ginfo(gid)%preq_cnt(vid)
2486  do i = 1, 32
2487  call mpi_testall( nreq, ginfo(gid)%preq_list(1:nreq,vid), &
2488  flag, mpi_statuses_ignore, ierr )
2489  enddo
2490 
2491  !$acc end host_data
2492 
2493  return
2494  end subroutine vars8_init_mpi_pc
2495 
2496  subroutine vars_3d_mpi(var, gid, vid)
2497  use scale_prc, only: &
2498  prc_abort
2499  use scale_prc_cartesc, only: &
2500  prc_twod
2501  implicit none
2502 
2503  real(RP), intent(inout) :: var(:,:,:)
2504  integer, intent(in) :: gid
2505  integer, intent(in) :: vid
2506 
2507 
2508  integer :: ireq, tag
2509 
2510  integer :: KA
2511  integer :: IA, IS, IE
2512  integer :: JA, JS, JE
2513  integer :: IHALO, JHALO
2514 
2515  integer :: ierr
2516 #ifdef _OPENACC
2517  real(RP), pointer :: ptr(:,:)
2518  logical :: flag_device
2519 #endif
2520  !---------------------------------------------------------------------------
2521 
2522  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
2523  ireq = 1
2524 
2525  ka = ginfo(gid)%KA
2526  ia = ginfo(gid)%IA
2527  is = ginfo(gid)%IS
2528  ie = ginfo(gid)%IE
2529  ja = ginfo(gid)%JA
2530  js = ginfo(gid)%JS
2531  je = ginfo(gid)%JE
2532  ihalo = ginfo(gid)%IHALO
2533  jhalo = ginfo(gid)%JHALO
2534 
2535 #ifdef DEBUG
2536  if ( ginfo(gid)%use_packbuf(vid) ) then
2537  log_error("vars_3D_mpi",*) 'packing buffer is already used', vid
2538  call prc_abort
2539  end if
2540  ginfo(gid)%use_packbuf(vid) = .true.
2541 #endif
2542 
2543 #ifdef _OPENACC
2544  flag_device = acc_is_present(var)
2545 #endif
2546 
2547  !$acc host_data use_device(var) if(flag_device)
2548 
2549  !--- From 4-Direction HALO communicate
2550  ! From S
2551  if ( prc_has_s ) then
2552  call mpi_irecv( var(:,:,1:js-1), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2553  prc_next(prc_s), tag+1, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2554  ireq = ireq + 1
2555  endif
2556  ! From N
2557  if ( prc_has_n ) then
2558  call mpi_irecv( var(:,:,je+1:ja), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2559  prc_next(prc_n), tag+2, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2560  ireq = ireq + 1
2561  endif
2562  if ( .not. prc_twod ) then
2563 #ifdef _OPENACC
2564  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
2565  !$acc host_data use_device(ptr) if(flag_device)
2566 #endif
2567  ! From E
2568  if ( prc_has_e ) then
2569 #ifdef _OPENACC
2570  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2571 #else
2572  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2573 #endif
2574  prc_next(prc_e), tag+3, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2575  ireq = ireq + 1
2576  endif
2577  ! From W
2578  if ( prc_has_w ) then
2579 #ifdef _OPENACC
2580  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2581 #else
2582  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2583 #endif
2584  prc_next(prc_w), tag+4, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2585  ireq = ireq + 1
2586  endif
2587  !$acc end host_data
2588  end if
2589 
2590  !$acc end host_data
2591 
2592  !--- To 4-Direction HALO communicate
2593  if ( .not. prc_twod ) then
2594  call packwe_3d( ka, ia, is, ie, ja, js, je, &
2595  ihalo, &
2596  var, gid, vid)
2597  end if
2598 
2599  !$acc host_data use_device(var) if(flag_device)
2600 
2601  ! To N HALO
2602  if ( prc_has_n ) then
2603  call mpi_isend( var(:,:,je-jhalo+1:je), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2604  prc_next(prc_n), tag+1, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2605  ireq = ireq + 1
2606  endif
2607  ! To S HALO
2608  if ( prc_has_s ) then
2609  call mpi_isend( var(:,:,js:js+jhalo-1), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2610  prc_next(prc_s), tag+2, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2611  ireq = ireq + 1
2612  endif
2613 
2614  !$acc end host_data
2615 
2616  if ( .not. prc_twod ) then
2617 #ifdef _OPENACC
2618  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
2619  !$acc wait
2620  !$acc host_data use_device(ptr) if(flag_device)
2621 #endif
2622  ! To W HALO
2623  if ( prc_has_w ) then
2624 #ifdef _OPENACC
2625  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2626 #else
2627  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2628 #endif
2629  prc_next(prc_w), tag+3, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2630  ireq = ireq + 1
2631  endif
2632  ! To E HALO
2633  if ( prc_has_e ) then
2634 #ifdef _OPENACC
2635  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2636 #else
2637  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2638 #endif
2639  prc_next(prc_e), tag+4, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2640  ireq = ireq + 1
2641  endif
2642 
2643  !$acc end host_data
2644  end if
2645 
2646  ginfo(gid)%req_cnt(vid) = ireq - 1
2647 
2648  return
2649  end subroutine vars_3d_mpi
2650 
2651  subroutine vars_3d_mpi_onesided(var, gid, vid)
2652  use scale_prc_cartesc, only: &
2653  prc_twod
2654  implicit none
2655 
2656  real(RP), intent(inout) :: var(:,:,:)
2657  integer, intent(in) :: gid
2658  integer, intent(in) :: vid
2659 
2660  integer :: KA
2661  integer :: IA, IS, IE
2662  integer :: JA, JS, JE
2663  integer :: IHALO, JHALO
2664 
2665  integer(kind=MPI_ADDRESS_KIND) :: disp
2666 
2667  integer :: ierr
2668 #ifdef _OPENACC
2669  real(RP), pointer :: ptr(:,:)
2670 #endif
2671  !---------------------------------------------------------------------------
2672 
2673  ka = ginfo(gid)%KA
2674  ia = ginfo(gid)%IA
2675  is = ginfo(gid)%IS
2676  ie = ginfo(gid)%IE
2677  ja = ginfo(gid)%JA
2678  js = ginfo(gid)%JS
2679  je = ginfo(gid)%JE
2680  ihalo = ginfo(gid)%IHALO
2681  jhalo = ginfo(gid)%JHALO
2682 
2683  !$acc data copyin(var)
2684 
2685  call mpi_win_start( group_packwe, 0, ginfo(gid)%win_packWE(vid), ierr )
2686  call mpi_win_start( group_packns, 0, ginfo(gid)%win_packNS(vid), ierr )
2687 
2688  !--- To 4-Direction HALO communicate
2689  if ( .not. prc_twod ) then
2690  call packwe_3d( ka, ia, is, ie, ja, js, je, &
2691  ihalo, &
2692  var, gid, vid)
2693  end if
2694 
2695  !$acc host_data use_device(var)
2696 
2697  ! To N HALO
2698  if ( prc_has_n ) then
2699  disp = 0
2700  call mpi_put( var(:,:,je-jhalo+1:je), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2701  prc_next(prc_n), disp, ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2702  ginfo(gid)%win_packNS(vid), ierr )
2703  endif
2704  ! To S HALO
2705  if ( prc_has_s ) then
2706  disp = ka * ia * jhalo
2707  call mpi_put( var(:,:,js:js+jhalo-1), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2708  prc_next(prc_s), disp, ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2709  ginfo(gid)%win_packNS(vid), ierr )
2710  endif
2711 
2712  !$acc end host_data
2713 
2714  if ( .not. prc_twod ) then
2715 #ifdef _OPENACC
2716  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
2717  !$acc wait
2718  !$acc host_data use_device(ptr)
2719 #endif
2720 
2721  ! To W HALO
2722  if ( prc_has_w ) then
2723  disp = 1
2724 #ifdef _OPENACC
2725  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2726 #else
2727  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2728 #endif
2729  prc_next(prc_w), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2730  ginfo(gid)%win_packWE(vid), ierr )
2731  endif
2732  ! To E HALO
2733  if ( prc_has_e ) then
2734  disp = 0
2735 #ifdef _OPENACC
2736  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2737 #else
2738  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2739 #endif
2740  prc_next(prc_e), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2741  ginfo(gid)%win_packWE(vid), ierr )
2742  endif
2743 
2744  !$acc end host_data
2745  end if
2746 
2747  call mpi_win_complete( ginfo(gid)%win_packWE(vid), ierr )
2748  call mpi_win_complete( ginfo(gid)%win_packNS(vid), ierr )
2749 
2750  !$acc end data
2751 
2752  return
2753  end subroutine vars_3d_mpi_onesided
2754 
2755  subroutine vars8_3d_mpi(var, gid, vid)
2756  use scale_prc, only: &
2757  prc_abort
2758  use scale_prc_cartesc, only: &
2759  prc_twod
2760  implicit none
2761 
2762  real(RP), intent(inout) :: var(:,:,:)
2763  integer, intent(in) :: gid
2764  integer, intent(in) :: vid
2765 
2766  integer :: ireq, tag, tagc
2767 
2768  integer :: KA
2769  integer :: IA, IS, IE
2770  integer :: JA, JS, JE
2771  integer :: IHALO, JHALO
2772 
2773  integer :: ierr
2774  integer :: j
2775 #ifdef _OPENACC
2776  real(RP), pointer :: ptr(:,:)
2777  logical :: flag_device
2778 #endif
2779  !---------------------------------------------------------------------------
2780 
2781  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
2782  tag = vid * 100
2783  ireq = 1
2784 
2785  ka = ginfo(gid)%KA
2786  ia = ginfo(gid)%IA
2787  is = ginfo(gid)%IS
2788  ie = ginfo(gid)%IE
2789  ja = ginfo(gid)%JA
2790  js = ginfo(gid)%JS
2791  je = ginfo(gid)%JE
2792  ihalo = ginfo(gid)%IHALO
2793  jhalo = ginfo(gid)%JHALO
2794 
2795 #ifdef DEBUG
2796  if ( ginfo(gid)%use_packbuf(vid) ) then
2797  log_error("vars8_3D_mpi",*) 'packing buffer is already used', vid
2798  call prc_abort
2799  end if
2800  ginfo(gid)%use_packbuf(vid) = .true.
2801 #endif
2802 
2803 #ifdef _OPENACC
2804  flag_device = acc_is_present(var)
2805 #endif
2806 
2807  if ( comm_isallperiodic ) then ! periodic condition
2808 
2809  !$acc host_data use_device(var) if(flag_device)
2810 
2811  !--- From 8-Direction HALO communicate
2812  if ( .not. prc_twod ) then
2813  ! From SE
2814  tagc = 0
2815  do j = 1, js-1
2816  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2817  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2818  ireq = ireq + 1
2819  tagc = tagc + 1
2820  enddo
2821  ! From SW
2822  tagc = 10
2823  do j = 1, js-1
2824  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2825  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2826  ireq = ireq + 1
2827  tagc = tagc + 1
2828  enddo
2829  ! From NE
2830  tagc = 20
2831  do j = je+1, ja
2832  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2833  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2834  ireq = ireq + 1
2835  tagc = tagc + 1
2836  enddo
2837  ! From NW
2838  tagc = 30
2839  do j = je+1, ja
2840  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2841  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2842  ireq = ireq + 1
2843  tagc = tagc + 1
2844  enddo
2845 #ifdef _OPENACC
2846  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
2847  !$acc host_data use_device(ptr) if(flag_device)
2848 #endif
2849  ! From E
2850  tagc = 60
2851 #ifdef _OPENACC
2852  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2853 #else
2854  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2855 #endif
2856  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2857  ireq = ireq + 1
2858  ! From W
2859  tagc = 70
2860 #ifdef _OPENACC
2861  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2862 #else
2863  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2864 #endif
2865  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2866  ireq = ireq + 1
2867  !$acc end host_data
2868  end if
2869  ! From S
2870  tagc = 40
2871  do j = 1, js-1
2872  call mpi_irecv( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2873  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2874  ireq = ireq + 1
2875  tagc = tagc + 1
2876  enddo
2877  ! From N
2878  tagc = 50
2879  do j = je+1, ja
2880  call mpi_irecv( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2881  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2882  ireq = ireq + 1
2883  tagc = tagc + 1
2884  enddo
2885 
2886  !--- To 8-Direction HALO communicate
2887  ! To N HALO
2888  tagc = 40
2889  do j = je-jhalo+1, je
2890  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2891  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2892  ireq = ireq + 1
2893  tagc = tagc + 1
2894  enddo
2895  ! To S HALO
2896  tagc = 50
2897  do j = js, js+jhalo-1
2898  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2899  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2900  ireq = ireq + 1
2901  tagc = tagc + 1
2902  enddo
2903 
2904  !$acc end host_data
2905 
2906  if ( .not. prc_twod ) then
2907 
2908  call packwe_3d( ka, ia, is, ie, ja, js, je, &
2909  ihalo, &
2910  var, gid, vid)
2911 
2912  !$acc host_data use_device(var) if(flag_device)
2913 
2914  ! To NW HALO
2915  tagc = 0
2916  do j = je-jhalo+1, je
2917  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2918  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2919  ireq = ireq + 1
2920  tagc = tagc + 1
2921  enddo
2922  ! To NE HALO
2923  tagc = 10
2924  do j = je-jhalo+1, je
2925  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2926  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2927  ireq = ireq + 1
2928  tagc = tagc + 1
2929  enddo
2930  ! To SW HALO
2931  tagc = 20
2932  do j = js, js+jhalo-1
2933  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2934  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2935  ireq = ireq + 1
2936  tagc = tagc + 1
2937  enddo
2938  ! To SE HALO
2939  tagc = 30
2940  do j = js, js+jhalo-1
2941  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2942  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2943  ireq = ireq + 1
2944  tagc = tagc + 1
2945  enddo
2946 
2947  !$acc end host_data
2948 
2949 #ifdef _OPENACC
2950  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
2951  !$acc wait
2952  !$acc host_data use_device(ptr) if(flag_device)
2953 #endif
2954  ! To W HALO
2955  tagc = 60
2956 #ifdef _OPENACC
2957  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2958 #else
2959  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2960 #endif
2961  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2962  ireq = ireq + 1
2963  ! To E HALO
2964  tagc = 70
2965 #ifdef _OPENACC
2966  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2967 #else
2968  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2969 #endif
2970  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2971  !$acc end host_data
2972  ireq = ireq + 1
2973 
2974  end if
2975 
2976  else ! non-periodic condition
2977 
2978  !$acc host_data use_device(var) if(flag_device)
2979 
2980  !--- From 8-Direction HALO communicate
2981  if ( .not. prc_twod ) then
2982  ! From SE
2983  if ( prc_has_s .AND. prc_has_e ) then
2984  tagc = 0
2985  do j = 1, js-1
2986  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2987  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2988  ireq = ireq + 1
2989  tagc = tagc + 1
2990  enddo
2991  else if ( prc_has_s ) then
2992  tagc = 0
2993  do j = 1, js-1
2994  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2995  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2996  ireq = ireq + 1
2997  tagc = tagc + 1
2998  enddo
2999  else if ( prc_has_e ) then
3000  tagc = 0
3001  do j = 1, js-1
3002  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3003  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3004  ireq = ireq + 1
3005  tagc = tagc + 1
3006  enddo
3007  endif
3008  ! From SW
3009  if ( prc_has_s .AND. prc_has_w ) then
3010  tagc = 10
3011  do j = 1, js-1
3012  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3013  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3014  ireq = ireq + 1
3015  tagc = tagc + 1
3016  enddo
3017  else if ( prc_has_s ) then
3018  tagc = 10
3019  do j = 1, js-1
3020  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3021  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3022  ireq = ireq + 1
3023  tagc = tagc + 1
3024  enddo
3025  else if ( prc_has_w ) then
3026  tagc = 10
3027  do j = 1, js-1
3028  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3029  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3030  ireq = ireq + 1
3031  tagc = tagc + 1
3032  enddo
3033  endif
3034  ! From NE
3035  if ( prc_has_n .AND. prc_has_e ) then
3036  tagc = 20
3037  do j = je+1, ja
3038  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3039  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3040  ireq = ireq + 1
3041  tagc = tagc + 1
3042  enddo
3043  else if ( prc_has_n ) then
3044  tagc = 20
3045  do j = je+1, ja
3046  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3047  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3048  ireq = ireq + 1
3049  tagc = tagc + 1
3050  enddo
3051  else if ( prc_has_e ) then
3052  tagc = 20
3053  do j = je+1, ja
3054  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3055  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3056  ireq = ireq + 1
3057  tagc = tagc + 1
3058  enddo
3059  endif
3060  ! From NW
3061  if ( prc_has_n .AND. prc_has_w ) then
3062  tagc = 30
3063  do j = je+1, ja
3064  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3065  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3066  ireq = ireq + 1
3067  tagc = tagc + 1
3068  enddo
3069  else if ( prc_has_n ) then
3070  tagc = 30
3071  do j = je+1, ja
3072  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3073  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3074  ireq = ireq + 1
3075  tagc = tagc + 1
3076  enddo
3077  else if ( prc_has_w ) then
3078  tagc = 30
3079  do j = je+1, ja
3080  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3081  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3082  ireq = ireq + 1
3083  tagc = tagc + 1
3084  enddo
3085  endif
3086 #ifdef _OPENACC
3087  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
3088  !$acc host_data use_device(ptr) if(flag_device)
3089 #endif
3090  ! From E
3091  if ( prc_has_e ) then
3092  tagc = 60
3093 #ifdef _OPENACC
3094  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3095 #else
3096  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3097 #endif
3098  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3099  ireq = ireq + 1
3100  endif
3101  ! From W
3102  if ( prc_has_w ) then
3103  tagc = 70
3104 #ifdef _OPENACC
3105  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3106 #else
3107  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3108 #endif
3109  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3110  ireq = ireq + 1
3111  endif
3112  !$acc end host_data
3113  end if
3114  ! From S
3115  if ( prc_has_s ) then
3116  tagc = 40
3117  do j = 1, js-1
3118  call mpi_irecv( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3119  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3120  ireq = ireq + 1
3121  tagc = tagc + 1
3122  enddo
3123  endif
3124  ! From N
3125  if ( prc_has_n ) then
3126  tagc = 50
3127  do j = je+1, ja
3128  call mpi_irecv( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3129  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3130  ireq = ireq + 1
3131  tagc = tagc + 1
3132  enddo
3133  endif
3134 
3135  !--- To 8-Direction HALO communicate
3136  ! To N HALO
3137  if ( prc_has_n ) then
3138  tagc = 40
3139  do j = je-jhalo+1, je
3140  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3141  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3142  ireq = ireq + 1
3143  tagc = tagc + 1
3144  enddo
3145  endif
3146  ! To S HALO
3147  if ( prc_has_s ) then
3148  tagc = 50
3149  do j = js, js+jhalo-1
3150  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3151  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3152  ireq = ireq + 1
3153  tagc = tagc + 1
3154  enddo
3155  endif
3156 
3157  !$acc end host_data
3158 
3159  if ( .not. prc_twod ) then
3160 
3161  call packwe_3d( ka, ia, is, ie, ja, js, je, &
3162  ihalo, &
3163  var, gid, vid)
3164 
3165  !$acc host_data use_device(var) if(flag_device)
3166 
3167  ! To NW HALO
3168  if ( prc_has_n .AND. prc_has_w ) then
3169  tagc = 0
3170  do j = je-jhalo+1, je
3171  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3172  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3173  ireq = ireq + 1
3174  tagc = tagc + 1
3175  enddo
3176  else if ( prc_has_n ) then
3177  tagc = 10
3178  do j = je-jhalo+1, je
3179  call mpi_isend( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3180  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3181  ireq = ireq + 1
3182  tagc = tagc + 1
3183  enddo
3184  else if ( prc_has_w ) then
3185  tagc = 20
3186  do j = je+1, ja
3187  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3188  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3189  ireq = ireq + 1
3190  tagc = tagc + 1
3191  enddo
3192  endif
3193  ! To NE HALO
3194  if ( prc_has_n .AND. prc_has_e ) then
3195  tagc = 10
3196  do j = je-jhalo+1, je
3197  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3198  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3199  ireq = ireq + 1
3200  tagc = tagc + 1
3201  enddo
3202  else if ( prc_has_n ) then
3203  tagc = 0
3204  do j = je-jhalo+1, je
3205  call mpi_isend( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3206  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3207  ireq = ireq + 1
3208  tagc = tagc + 1
3209  enddo
3210  else if ( prc_has_e ) then
3211  tagc = 30
3212  do j = je+1, ja
3213  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3214  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3215  ireq = ireq + 1
3216  tagc = tagc + 1
3217  enddo
3218  endif
3219  ! To SW HALO
3220  if ( prc_has_s .AND. prc_has_w ) then
3221  tagc = 20
3222  do j = js, js+jhalo-1
3223  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3224  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3225  ireq = ireq + 1
3226  tagc = tagc + 1
3227  enddo
3228  else if ( prc_has_s ) then
3229  tagc = 30
3230  do j = js, js+jhalo-1
3231  call mpi_isend( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3232  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3233  ireq = ireq + 1
3234  tagc = tagc + 1
3235  enddo
3236  else if ( prc_has_w ) then
3237  tagc = 0
3238  do j = 1, js-1
3239  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3240  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3241  ireq = ireq + 1
3242  tagc = tagc + 1
3243  enddo
3244  endif
3245  ! To SE HALO
3246  if ( prc_has_s .AND. prc_has_e ) then
3247  tagc = 30
3248  do j = js, js+jhalo-1
3249  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3250  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3251  ireq = ireq + 1
3252  tagc = tagc + 1
3253  enddo
3254  else if ( prc_has_s ) then
3255  tagc = 20
3256  do j = js, js+jhalo-1
3257  call mpi_isend( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3258  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3259  ireq = ireq + 1
3260  tagc = tagc + 1
3261  enddo
3262  else if ( prc_has_e ) then
3263  tagc = 10
3264  do j = 1, js-1
3265  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3266  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3267  ireq = ireq + 1
3268  tagc = tagc + 1
3269  enddo
3270  endif
3271 
3272  !$acc end host_data
3273 
3274 #ifdef _OPENACC
3275  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
3276  !$acc wait
3277  !$acc host_data use_device(ptr) if(flag_device)
3278 #endif
3279 
3280  ! To W HALO
3281  if ( prc_has_w ) then
3282  tagc = 60
3283 #ifdef _OPENACC
3284  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3285 #else
3286  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3287 #endif
3288  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3289  ireq = ireq + 1
3290  endif
3291  ! To E HALO
3292  if ( prc_has_e ) then
3293  tagc = 70
3294 #ifdef _OPENACC
3295  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3296 #else
3297  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3298 #endif
3299  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3300  ireq = ireq + 1
3301  endif
3302  !$acc end host_data
3303 
3304  end if
3305 
3306  endif
3307 
3308  ginfo(gid)%req_cnt(vid) = ireq - 1
3309 
3310  return
3311  end subroutine vars8_3d_mpi
3312 
3313  subroutine vars8_3d_mpi_onesided(var, gid, vid)
3314  use scale_prc_cartesc, only: &
3315  prc_twod
3316  implicit none
3317 
3318  real(RP), intent(inout) :: var(:,:,:)
3319  integer, intent(in) :: gid
3320  integer, intent(in) :: vid
3321 
3322  integer :: KA
3323  integer :: IA, IS, IE
3324  integer :: JA, JS, JE
3325  integer :: IHALO, JHALO
3326 
3327  integer(kind=MPI_ADDRESS_KIND) :: disp
3328 
3329  integer :: ierr
3330  integer :: j
3331 #ifdef _OPENACC
3332  real(RP), pointer :: ptr(:,:)
3333 #endif
3334  !---------------------------------------------------------------------------
3335 
3336  ka = ginfo(gid)%KA
3337  ia = ginfo(gid)%IA
3338  is = ginfo(gid)%IS
3339  ie = ginfo(gid)%IE
3340  ja = ginfo(gid)%JA
3341  js = ginfo(gid)%JS
3342  je = ginfo(gid)%JE
3343  ihalo = ginfo(gid)%IHALO
3344  jhalo = ginfo(gid)%JHALO
3345 
3346  !$acc data copyin(var)
3347  call mpi_win_start( group_packwe, 0, ginfo(gid)%win_packWE(vid), ierr )
3348  call mpi_win_start( group_packns, 0, ginfo(gid)%win_packNS(vid), ierr )
3349 
3350  if ( comm_isallperiodic ) then ! periodic condition
3351 
3352  !$acc host_data use_device(var)
3353 
3354  !--- To 8-Direction HALO communicate
3355  ! To N HALO
3356  do j = je-jhalo+1, je
3357  disp = ka * ( ihalo + ia * ( j - je+jhalo-1 ) )
3358  call mpi_put( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3359  prc_next(prc_n), disp, ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3360  ginfo(gid)%win_packNS(vid), ierr )
3361  enddo
3362  ! To S HALO
3363  do j = js, js+jhalo-1
3364  disp = ka * ( ihalo + ia * ( j - js + jhalo ) )
3365  call mpi_put( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3366  prc_next(prc_s), disp, ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3367  ginfo(gid)%win_packNS(vid), ierr )
3368  enddo
3369 
3370  !$acc end host_data
3371 
3372  if ( .not. prc_twod ) then
3373 
3374  call packwe_3d( ka, ia, is, ie, ja, js, je, &
3375  ihalo, &
3376  var, gid, vid)
3377 
3378  !$acc host_data use_device(var)
3379  ! To NW HALO
3380  do j = je-jhalo+1, je
3381  disp = ka * ( ie + ia * ( j - je+jhalo-1 ) )
3382  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3383  prc_next(prc_nw), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3384  ginfo(gid)%win_packNS(vid), ierr )
3385  enddo
3386  ! To NE HALO
3387  do j = je-jhalo+1, je
3388  disp = ka * ( ia * ( j - je+jhalo-1 ) )
3389  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3390  prc_next(prc_ne), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3391  ginfo(gid)%win_packNS(vid), ierr )
3392  enddo
3393  ! To SW HALO
3394  do j = js, js+jhalo-1
3395  disp = ka * ( ie + ia * ( j - js + jhalo ) )
3396  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3397  prc_next(prc_sw), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3398  ginfo(gid)%win_packNS(vid), ierr )
3399  enddo
3400  ! To SE HALO
3401  do j = js, js+jhalo-1
3402  disp = ka * ( ia * ( j - js + jhalo ) )
3403  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3404  prc_next(prc_se), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3405  ginfo(gid)%win_packNS(vid), ierr )
3406  enddo
3407 
3408  !$acc end host_data
3409 
3410 #ifdef _OPENACC
3411  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
3412  !$acc wait
3413  !$acc host_data use_device(ptr)
3414 #endif
3415  ! To W HALO
3416  disp = 1
3417 #ifdef _OPENACC
3418  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3419 #else
3420  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3421 #endif
3422  prc_next(prc_w), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3423  ginfo(gid)%win_packWE(vid), ierr )
3424  ! To E HALO
3425  disp = 0
3426 #ifdef _OPENACC
3427  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3428 #else
3429  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3430 #endif
3431  prc_next(prc_e), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3432  ginfo(gid)%win_packWE(vid), ierr )
3433  !$acc end host_data
3434 
3435  end if
3436 
3437  else ! non-periodic condition
3438 
3439  !$acc host_data use_device(var)
3440 
3441  !--- To 8-Direction HALO communicate
3442  ! To N HALO
3443  if ( prc_has_n ) then
3444  do j = je-jhalo+1, je
3445  disp = ka * ( ihalo + ia * ( j - je+jhalo-1 ) )
3446  call mpi_put( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3447  prc_next(prc_n), disp, ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3448  ginfo(gid)%win_packNS(vid), ierr )
3449  enddo
3450  endif
3451  ! To S HALO
3452  if ( prc_has_s ) then
3453  do j = js, js+jhalo-1
3454  disp = ka * ( ihalo + ia * ( j - js + jhalo ) )
3455  call mpi_put( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3456  prc_next(prc_s), disp, ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3457  ginfo(gid)%win_packNS(vid), ierr )
3458  enddo
3459  endif
3460 
3461  !$acc end host_data
3462 
3463  if ( .not. prc_twod ) then
3464 
3465  call packwe_3d( ka, ia, is, ie, ja, js, je, &
3466  ihalo, &
3467  var, gid, vid)
3468 
3469  !$acc host_data use_device(var)
3470 
3471  ! To NW HALO
3472  if ( prc_has_n .AND. prc_has_w ) then
3473  do j = je-jhalo+1, je
3474  disp = ka * ( ie + ia * ( j - je+jhalo-1 ) )
3475  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3476  prc_next(prc_nw), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3477  ginfo(gid)%win_packNS(vid), ierr )
3478  enddo
3479  else if ( prc_has_n ) then
3480  do j = je-jhalo+1, je
3481  disp = ka * ( ia * ( j - je+jhalo-1 ) )
3482  call mpi_put( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3483  prc_next(prc_n), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3484  ginfo(gid)%win_packNS(vid), ierr )
3485  enddo
3486  else if ( prc_has_w ) then
3487  do j = je+1, ja
3488  disp = ka * ( ie + ia * ( j - je-1 + jhalo ) )
3489  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3490  prc_next(prc_w), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3491  ginfo(gid)%win_packNS(vid), ierr )
3492  enddo
3493  endif
3494  ! To NE HALO
3495  if ( prc_has_n .AND. prc_has_e ) then
3496  do j = je-jhalo+1, je
3497  disp = ka * ( ia * ( j - je+jhalo-1 ) )
3498  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3499  prc_next(prc_ne), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3500  ginfo(gid)%win_packNS(vid), ierr )
3501  enddo
3502  else if ( prc_has_n ) then
3503  do j = je-jhalo+1, je
3504  disp = ka * ( ie + ia * ( j - je+jhalo-1 ) )
3505  call mpi_put( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3506  prc_next(prc_n), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3507  ginfo(gid)%win_packNS(vid), ierr )
3508  enddo
3509  else if ( prc_has_e ) then
3510  do j = je+1, ja
3511  disp = ka * ia * ( j - je-1 + jhalo )
3512  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3513  prc_next(prc_e), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3514  ginfo(gid)%win_packNS(vid), ierr )
3515  enddo
3516  endif
3517  ! To SW HALO
3518  if ( prc_has_s .AND. prc_has_w ) then
3519  do j = js, js+jhalo-1
3520  disp = ka * ( ie + ia * ( j - js + jhalo ) )
3521  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3522  prc_next(prc_sw), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3523  ginfo(gid)%win_packNS(vid), ierr )
3524  enddo
3525  else if ( prc_has_s ) then
3526  do j = js, js+jhalo-1
3527  disp = ka * ( ia * ( j - js + jhalo ) )
3528  call mpi_put( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3529  prc_next(prc_s), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3530  ginfo(gid)%win_packNS(vid), ierr )
3531  enddo
3532  else if ( prc_has_w ) then
3533  do j = 1, js-1
3534  disp = ka * ( ie + ia * (j-1) )
3535  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3536  prc_next(prc_w), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3537  ginfo(gid)%win_packNS(vid), ierr )
3538  enddo
3539  endif
3540  ! To SE HALO
3541  if ( prc_has_s .AND. prc_has_e ) then
3542  do j = js, js+jhalo-1
3543  disp = ka * ( ia * ( j - js + jhalo ) )
3544  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3545  prc_next(prc_se), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3546  ginfo(gid)%win_packNS(vid), ierr )
3547  enddo
3548  else if ( prc_has_s ) then
3549  do j = js, js+jhalo-1
3550  disp = ka * ( ie + ia * ( j - js + jhalo ) )
3551  call mpi_put( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3552  prc_next(prc_s), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3553  ginfo(gid)%win_packNS(vid), ierr )
3554  enddo
3555  else if ( prc_has_e ) then
3556  do j = 1, js-1
3557  disp = ka * ( ia * ( j - 1 ) )
3558  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3559  prc_next(prc_e), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3560  ginfo(gid)%win_packNS(vid), ierr )
3561  enddo
3562  endif
3563 
3564  !$acc end host_data
3565 
3566 #ifdef _OPENACC
3567  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
3568  !$acc wait
3569  !$acc host_data use_device(ptr)
3570 #endif
3571 
3572  ! To W HALO
3573  if ( prc_has_w ) then
3574  disp = 1
3575 #ifdef _OPENACC
3576  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3577 #else
3578  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3579 #endif
3580  prc_next(prc_w), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3581  ginfo(gid)%win_packWE(vid), ierr )
3582  endif
3583  ! To E HALO
3584  if ( prc_has_e ) then
3585  disp = 0
3586 #ifdef _OPENACC
3587  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3588 #else
3589  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3590 #endif
3591  prc_next(prc_e), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3592  ginfo(gid)%win_packWE(vid), ierr )
3593  endif
3594  !$acc end host_data
3595 
3596  end if
3597 
3598  endif
3599 
3600  call mpi_win_complete( ginfo(gid)%win_packWE(vid), ierr )
3601  call mpi_win_complete( ginfo(gid)%win_packNS(vid), ierr )
3602 
3603  !$acc end data
3604 
3605  return
3606  end subroutine vars8_3d_mpi_onesided
3607 
3608  subroutine vars_2d_mpi(var, gid, vid)
3609  use scale_prc, only: &
3610  prc_abort
3611  use scale_prc_cartesc, only: &
3612  prc_twod
3613  implicit none
3614 
3615  real(RP), intent(inout) :: var(:,:)
3616  integer, intent(in) :: gid
3617  integer, intent(in) :: vid
3618 
3619  integer :: IA, IS, IE
3620  integer :: JA, JS, JE
3621  integer :: IHALO, JHALO
3622 
3623  integer :: ireq, tag
3624  integer :: ierr
3625 #ifdef _OPENACC
3626  real(RP), pointer :: ptr(:,:)
3627  logical :: flag_device
3628 #endif
3629  !---------------------------------------------------------------------------
3630 
3631  ia = ginfo(gid)%IA
3632  is = ginfo(gid)%IS
3633  ie = ginfo(gid)%IE
3634  ja = ginfo(gid)%JA
3635  js = ginfo(gid)%JS
3636  je = ginfo(gid)%JE
3637  ihalo = ginfo(gid)%IHALO
3638  jhalo = ginfo(gid)%JHALO
3639 
3640  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
3641  ireq = 1
3642 
3643 #ifdef DEBUG
3644  if ( ginfo(gid)%use_packbuf(vid) ) then
3645  log_error("vars_2D_mpi",*) 'packing buffer is already used', vid
3646  call prc_abort
3647  end if
3648  ginfo(gid)%use_packbuf(vid) = .true.
3649 #endif
3650 
3651 #ifdef _OPENACC
3652  flag_device = acc_is_present(var)
3653 #endif
3654 
3655  !$acc host_data use_device(var) if(flag_device)
3656 
3657  !--- From 4-Direction HALO communicate
3658  ! From S
3659  if ( prc_has_s ) then
3660  call mpi_irecv( var(:,1:js-1), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3661  prc_next(prc_s), tag+1, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3662  ireq = ireq + 1
3663  endif
3664  ! From N
3665  if ( prc_has_n ) then
3666  call mpi_irecv( var(:,je+1:ja), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3667  prc_next(prc_n), tag+2, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3668  ireq = ireq + 1
3669  endif
3670 
3671  if ( .not. prc_twod ) then
3672 #ifdef _OPENACC
3673  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
3674  !$acc host_data use_device(ptr) if(flag_device)
3675 #endif
3676  ! From E
3677  if ( prc_has_e ) then
3678 #ifdef _OPENACC
3679  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE, comm_datatype_t, &
3680 #else
3681  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3682 #endif
3683  prc_next(prc_e), tag+3, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3684  ireq = ireq + 1
3685  endif
3686  ! From W
3687  if ( prc_has_w ) then
3688 #ifdef _OPENACC
3689  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE, comm_datatype_t, &
3690 #else
3691  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3692 #endif
3693  prc_next(prc_w), tag+4, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3694  ireq = ireq + 1
3695  endif
3696  !$acc end host_data
3697  end if
3698 
3699  !$acc end host_data
3700 
3701  !--- To 4-Direction HALO communicate
3702  if ( .not. prc_twod ) then
3703 
3704  call packwe_2d( ia, is, ie, ja, js, je, &
3705  ihalo, &
3706  var, gid, vid)
3707 
3708 #ifdef _OPENACC
3709  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
3710  !$acc host_data use_device(ptr) if(flag_device)
3711 #endif
3712 
3713  ! To W HALO communicate
3714  if ( prc_has_w ) then
3715 #ifdef _OPENACC
3716  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE, comm_datatype_t, &
3717 #else
3718  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3719 #endif
3720  prc_next(prc_w), tag+3, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3721  ireq = ireq + 1
3722  endif
3723  ! To E HALO communicate
3724  if ( prc_has_e ) then
3725 #ifdef _OPENACC
3726  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE, comm_datatype_t, &
3727 #else
3728  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3729 #endif
3730  prc_next(prc_e), tag+4, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3731  ireq = ireq + 1
3732  endif
3733 
3734  !$acc end host_data
3735 
3736  end if
3737 
3738  !$acc host_data use_device(var) if(flag_device)
3739 
3740  ! To N HALO communicate
3741  if ( prc_has_n ) then
3742  call mpi_isend( var(:,je-jhalo+1:je), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3743  prc_next(prc_n), tag+1, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3744  ireq = ireq + 1
3745  endif
3746  ! To S HALO communicate
3747  if ( prc_has_s ) then
3748  call mpi_isend( var(:,js:js+jhalo-1), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3749  prc_next(prc_s), tag+2, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3750  ireq = ireq + 1
3751  endif
3752 
3753  !$acc end host_data
3754 
3755  ginfo(gid)%req_cnt(vid) = ireq - 1
3756 
3757  return
3758  end subroutine vars_2d_mpi
3759 
3760  subroutine vars_2d_mpi_onesided(var, gid, vid)
3761  use scale_prc_cartesc, only: &
3762  prc_twod
3763  implicit none
3764 
3765  real(RP), intent(inout) :: var(:,:)
3766  integer, intent(in) :: gid
3767  integer, intent(in) :: vid
3768 
3769  integer :: IA, IS, IE
3770  integer :: JA, JS, JE
3771  integer :: IHALO, JHALO
3772 
3773  integer(kind=MPI_ADDRESS_KIND) :: disp
3774 
3775  integer :: ierr
3776 #ifdef _OPENACC
3777  real(RP), pointer :: ptr(:,:)
3778 #endif
3779  !---------------------------------------------------------------------------
3780 
3781  ia = ginfo(gid)%IA
3782  is = ginfo(gid)%IS
3783  ie = ginfo(gid)%IE
3784  ja = ginfo(gid)%JA
3785  js = ginfo(gid)%JS
3786  je = ginfo(gid)%JE
3787  ihalo = ginfo(gid)%IHALO
3788  jhalo = ginfo(gid)%JHALO
3789 
3790  !$acc data copyin(var)
3791 
3792  call mpi_win_start( group_packwe, 0, ginfo(gid)%win_packWE(vid), ierr )
3793  call mpi_win_start( group_packns, 0, ginfo(gid)%win_packNS(vid), ierr )
3794 
3795  !--- To 4-Direction HALO communicate
3796 
3797  if ( .not. prc_twod ) then
3798 
3799  call packwe_2d( ia, is, ie, ja, js, je, &
3800  ihalo, &
3801  var, gid, vid)
3802 
3803 #ifdef _OPENACC
3804  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
3805  !$acc host_data use_device(ptr)
3806 #endif
3807 
3808  ! To W HALO communicate
3809  if ( prc_has_w ) then
3810  disp = 1
3811 #ifdef _OPENACC
3812  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE, comm_datatype_t, &
3813 #else
3814  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3815 #endif
3816  prc_next(prc_w), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
3817  ginfo(gid)%win_packWE(vid), ierr )
3818  endif
3819  ! To E HALO communicate
3820  if ( prc_has_e ) then
3821  disp = 0
3822 #ifdef _OPENACC
3823  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE, comm_datatype_t, &
3824 #else
3825  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3826 #endif
3827  prc_next(prc_e), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
3828  ginfo(gid)%win_packWE(vid), ierr )
3829  endif
3830 
3831  !$acc end host_data
3832 
3833  end if
3834 
3835  !$acc host_data use_device(var)
3836 
3837  ! To N HALO communicate
3838  if ( prc_has_n ) then
3839  disp = 0
3840  call mpi_put( var(:,je-jhalo+1:je), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3841  prc_next(prc_n), disp, ginfo(gid)%size2D_NS4, comm_datatype_t, &
3842  ginfo(gid)%win_packNS(vid), ierr )
3843  endif
3844  ! To S HALO communicate
3845  if ( prc_has_s ) then
3846  disp = ia * jhalo
3847  call mpi_put( var(:,js:js+jhalo-1), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3848  prc_next(prc_s), disp, ginfo(gid)%size2D_NS4, comm_datatype_t, &
3849  ginfo(gid)%win_packNS(vid), ierr )
3850  endif
3851 
3852  !$acc end host_data
3853 
3854  call mpi_win_complete( ginfo(gid)%win_packWE(vid), ierr )
3855  call mpi_win_complete( ginfo(gid)%win_packNS(vid), ierr )
3856 
3857  !$acc end data
3858 
3859  return
3860  end subroutine vars_2d_mpi_onesided
3861 
3862  subroutine vars8_2d_mpi(var, gid, vid)
3863  use scale_prc, only: &
3864  prc_abort
3865  use scale_prc_cartesc, only: &
3866  prc_twod
3867  implicit none
3868 
3869  real(RP), intent(inout) :: var(:,:)
3870  integer, intent(in) :: gid
3871  integer, intent(in) :: vid
3872 
3873  integer :: IA, IS, IE
3874  integer :: JA, JS, JE
3875  integer :: IHALO, JHALO
3876 
3877  integer :: ireq, tag, tagc
3878 
3879  integer :: ierr
3880  integer :: j
3881 #ifdef _OPENACC
3882  real(RP), pointer :: ptr(:,:)
3883  logical :: flag_device
3884 #endif
3885  !---------------------------------------------------------------------------
3886 
3887  ia = ginfo(gid)%IA
3888  is = ginfo(gid)%IS
3889  ie = ginfo(gid)%IE
3890  ja = ginfo(gid)%JA
3891  js = ginfo(gid)%JS
3892  je = ginfo(gid)%JE
3893  ihalo = ginfo(gid)%IHALO
3894  jhalo = ginfo(gid)%JHALO
3895 
3896  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
3897  ireq = 1
3898 
3899 #ifdef DEBUG
3900  if ( ginfo(gid)%use_packbuf(vid) ) then
3901  log_error("vars8_2D_mpi",*) 'packing buffer is already used', vid
3902  call prc_abort
3903  end if
3904  ginfo(gid)%use_packbuf(vid) = .true.
3905 #endif
3906 
3907 #ifdef _OPENACC
3908  flag_device = acc_is_present(var)
3909 #endif
3910 
3911  if ( comm_isallperiodic ) then
3912  !--- periodic condition
3913  !--- From 8-Direction HALO communicate
3914  !$acc host_data use_device(var) if(flag_device)
3915 
3916  if ( .not. prc_twod ) then
3917  ! From SE
3918  tagc = 0
3919  do j = 1, js-1
3920  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
3921  comm_datatype_t, prc_next(prc_se), tag+tagc, &
3922  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3923  ireq = ireq + 1
3924  tagc = tagc + 1
3925  enddo
3926  ! From SW
3927  tagc = 10
3928  do j = 1, js-1
3929  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
3930  comm_datatype_t, prc_next(prc_sw), tag+tagc, &
3931  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3932  ireq = ireq + 1
3933  tagc = tagc + 1
3934  enddo
3935  ! From NE
3936  tagc = 20
3937  do j = je+1, ja
3938  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
3939  comm_datatype_t, prc_next(prc_ne), tag+tagc, &
3940  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3941  ireq = ireq + 1
3942  tagc = tagc + 1
3943  enddo
3944  ! From NW
3945  tagc = 30
3946  do j = je+1, ja
3947  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
3948  comm_datatype_t, prc_next(prc_nw), tag+tagc, &
3949  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3950  ireq = ireq + 1
3951  tagc = tagc + 1
3952  enddo
3953 #ifdef _OPENACC
3954  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
3955  !$acc host_data use_device(ptr) if(flag_device)
3956 #endif
3957  ! From E
3958 #ifdef _OPENACC
3959  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE, &
3960 #else
3961  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE, &
3962 #endif
3963  comm_datatype_t, prc_next(prc_e), tag+60, &
3964  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3965  ireq = ireq + 1
3966  ! From W
3967 #ifdef _OPENACC
3968  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE, &
3969 #else
3970  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE, &
3971 #endif
3972  comm_datatype_t, prc_next(prc_w), tag+70, &
3973  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3974  ireq = ireq + 1
3975  !$acc end host_data
3976  end if
3977  ! From S
3978  tagc = 40
3979  do j = 1, js-1
3980  call mpi_irecv( var(is,j), ginfo(gid)%size2D_NS8, &
3981  comm_datatype_t, prc_next(prc_s), tag+tagc, &
3982  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3983  ireq = ireq + 1
3984  tagc = tagc + 1
3985  enddo
3986  ! From N
3987  tagc = 50
3988  do j = je+1, ja
3989  call mpi_irecv( var(is,j), ginfo(gid)%size2D_NS8, &
3990  comm_datatype_t, prc_next(prc_n), tag+tagc, &
3991  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3992  ireq = ireq + 1
3993  tagc = tagc + 1
3994  enddo
3995 
3996 
3997  !--- To 8-Direction HALO communicate
3998 
3999  ! To N HALO communicate
4000  tagc = 40
4001  do j = je-jhalo+1, je
4002  call mpi_isend( var(is,j), ginfo(gid)%size2D_NS8, &
4003  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4004  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4005  ireq = ireq + 1
4006  tagc = tagc + 1
4007  enddo
4008 
4009  ! To S HALO communicate
4010  tagc = 50
4011  do j = js, js+jhalo-1
4012  call mpi_isend( var(is,j), ginfo(gid)%size2D_NS8, &
4013  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4014  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4015  ireq = ireq + 1
4016  tagc = tagc + 1
4017  enddo
4018 
4019  !$acc end host_data
4020 
4021  if ( .not. prc_twod ) then
4022 
4023  call packwe_2d( ia, is, ie, ja, js, je, &
4024  ihalo, &
4025  var, gid, vid)
4026 
4027  !$acc host_data use_device(var) if(flag_device)
4028 #ifdef _OPENACC
4029  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
4030  !$acc host_data use_device(ptr) if(flag_device)
4031 #endif
4032 
4033  ! To W HALO communicate
4034 #ifdef _OPENACC
4035  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE, &
4036 #else
4037  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, &
4038 #endif
4039  comm_datatype_t, prc_next(prc_w), tag+60, &
4040  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4041  ireq = ireq + 1
4042 
4043  ! To E HALO communicate
4044 #ifdef _OPENACC
4045  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE, &
4046 #else
4047  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, &
4048 #endif
4049  comm_datatype_t, prc_next(prc_e), tag+70, &
4050  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4051  ireq = ireq + 1
4052  !$acc end host_data
4053 
4054  ! To NW HALO communicate
4055  tagc = 0
4056  do j = je-jhalo+1, je
4057  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4058  comm_datatype_t, prc_next(prc_nw), tag+tagc, &
4059  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4060  ireq = ireq + 1
4061  tagc = tagc + 1
4062  enddo
4063 
4064  ! To NE HALO communicate
4065  tagc = 10
4066  do j = je-jhalo+1, je
4067  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4068  comm_datatype_t, prc_next(prc_ne), tag+tagc, &
4069  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4070  ireq = ireq + 1
4071  tagc = tagc + 1
4072  enddo
4073 
4074  ! To SW HALO communicate
4075  tagc = 20
4076  do j = js, js+jhalo-1
4077  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4078  comm_datatype_t, prc_next(prc_sw), tag+tagc, &
4079  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4080  ireq = ireq + 1
4081  tagc = tagc + 1
4082  enddo
4083 
4084  ! To SE HALO communicate
4085  tagc = 30
4086  do j = js, js+jhalo-1
4087  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4088  comm_datatype_t, prc_next(prc_se), tag+tagc, &
4089  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4090  ireq = ireq + 1
4091  tagc = tagc + 1
4092  enddo
4093 
4094  !$acc end host_data
4095 
4096  end if
4097 
4098  else
4099  !--- non-periodic condition
4100  !--- From 8-Direction HALO communicate
4101 
4102  !$acc host_data use_device(var) if(flag_device)
4103 
4104  if ( .not. prc_twod ) then
4105  ! From SE
4106  if ( prc_has_s .AND. prc_has_e ) then
4107  tagc = 0
4108  do j = 1, js-1
4109  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4110  comm_datatype_t, prc_next(prc_se), tag+tagc, &
4111  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4112  ireq = ireq + 1
4113  tagc = tagc + 1
4114  enddo
4115  else if ( prc_has_s ) then
4116  tagc = 0
4117  do j = 1, js-1
4118  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4119  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4120  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4121  ireq = ireq + 1
4122  tagc = tagc + 1
4123  enddo
4124  else if ( prc_has_e ) then
4125  tagc = 0
4126  do j = 1, js-1
4127  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4128  comm_datatype_t, prc_next(prc_e), tag+tagc, &
4129  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4130  ireq = ireq + 1
4131  tagc = tagc + 1
4132  enddo
4133  endif
4134 
4135  ! From SW
4136  if ( prc_has_s .AND. prc_has_w ) then
4137  tagc = 10
4138  do j = 1, js-1
4139  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4140  comm_datatype_t, prc_next(prc_sw), tag+tagc, &
4141  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4142  ireq = ireq + 1
4143  tagc = tagc + 1
4144  enddo
4145  else if ( prc_has_s ) then
4146  tagc = 10
4147  do j = 1, js-1
4148  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4149  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4150  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4151  ireq = ireq + 1
4152  tagc = tagc + 1
4153  enddo
4154  else if ( prc_has_w ) then
4155  tagc = 10
4156  do j = 1, js-1
4157  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4158  comm_datatype_t, prc_next(prc_w), tag+tagc, &
4159  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4160  ireq = ireq + 1
4161  tagc = tagc + 1
4162  enddo
4163  endif
4164 
4165  ! From NE
4166  if ( prc_has_n .AND. prc_has_e ) then
4167  tagc = 20
4168  do j = je+1, je+jhalo
4169  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4170  comm_datatype_t, prc_next(prc_ne), tag+tagc, &
4171  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4172  ireq = ireq + 1
4173  tagc = tagc + 1
4174  enddo
4175  else if ( prc_has_n ) then
4176  tagc = 20
4177  do j = je+1, ja
4178  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4179  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4180  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4181  ireq = ireq + 1
4182  tagc = tagc + 1
4183  enddo
4184  else if ( prc_has_e ) then
4185  tagc = 20
4186  do j = je+1, ja
4187  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4188  comm_datatype_t, prc_next(prc_e), tag+tagc, &
4189  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4190  ireq = ireq + 1
4191  tagc = tagc + 1
4192  enddo
4193  endif
4194 
4195  ! From NW
4196  if ( prc_has_n .AND. prc_has_w ) then
4197  tagc = 30
4198  do j = je+1, ja
4199  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4200  comm_datatype_t, prc_next(prc_nw), tag+tagc, &
4201  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4202  ireq = ireq + 1
4203  tagc = tagc + 1
4204  enddo
4205  else if ( prc_has_n ) then
4206  tagc = 30
4207  do j = je+1, ja
4208  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4209  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4210  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4211  ireq = ireq + 1
4212  tagc = tagc + 1
4213  enddo
4214  else if ( prc_has_w ) then
4215  tagc = 30
4216  do j = je+1, ja
4217  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4218  comm_datatype_t, prc_next(prc_w), tag+tagc, &
4219  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4220  ireq = ireq + 1
4221  tagc = tagc + 1
4222  enddo
4223  endif
4224 
4225 #ifdef _OPENACC
4226  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
4227  !$acc host_data use_device(ptr) if(flag_device)
4228 #endif
4229  ! From E
4230  if ( prc_has_e ) then
4231 #ifdef _OPENACC
4232  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE, &
4233 #else
4234  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE, &
4235 #endif
4236  comm_datatype_t, prc_next(prc_e), tag+60, &
4237  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4238  ireq = ireq + 1
4239  endif
4240 
4241  ! From W
4242  if ( prc_has_w ) then
4243 #ifdef _OPENACC
4244  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE, &
4245 #else
4246  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE, &
4247 #endif
4248  comm_datatype_t, prc_next(prc_w), tag+70, &
4249  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4250  ireq = ireq + 1
4251  endif
4252  !$acc end host_data
4253 
4254  end if
4255 
4256  ! From S
4257  if ( prc_has_s ) then
4258  tagc = 40
4259  do j = 1, js-1
4260  call mpi_irecv( var(is,j), ginfo(gid)%size2D_NS8, &
4261  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4262  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4263  ireq = ireq + 1
4264  tagc = tagc + 1
4265  enddo
4266  endif
4267 
4268  ! From N
4269  if ( prc_has_n ) then
4270  tagc = 50
4271  do j = je+1, ja
4272  call mpi_irecv( var(is,j), ginfo(gid)%size2D_NS8, &
4273  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4274  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4275  ireq = ireq + 1
4276  tagc = tagc + 1
4277  enddo
4278  endif
4279 
4280 
4281  !! RECEIVE
4282 
4283  ! To N HALO communicate
4284  if ( prc_has_n ) then
4285  tagc = 40
4286  do j = je-jhalo+1, je
4287  call mpi_isend( var(is,j), ginfo(gid)%size2D_NS8, &
4288  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4289  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4290  ireq = ireq + 1
4291  tagc = tagc + 1
4292  enddo
4293  endif
4294 
4295  ! To S HALO communicate
4296  if ( prc_has_s ) then
4297  tagc = 50
4298  do j = js, js+jhalo-1
4299  call mpi_isend( var(is,j), ginfo(gid)%size2D_NS8, &
4300  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4301  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4302  ireq = ireq + 1
4303  tagc = tagc + 1
4304  enddo
4305  endif
4306 
4307  !$acc end host_data
4308 
4309  if ( .not. prc_twod ) then
4310 
4311  call packwe_2d( ia, is, ie, ja, js, je, &
4312  ihalo, &
4313  var, gid, vid)
4314 
4315  !$acc host_data use_device(var) if(flag_device)
4316 #ifdef _OPENACC
4317  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
4318  !$acc host_data use_device(ptr) if(flag_device)
4319 #endif
4320 
4321  ! To W HALO communicate
4322  if ( prc_has_w ) then
4323 #ifdef _OPENACC
4324  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE, &
4325 #else
4326  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, &
4327 #endif
4328  comm_datatype_t, prc_next(prc_w), tag+60, &
4329  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4330  ireq = ireq + 1
4331  endif
4332 
4333  ! To E HALO communicate
4334  if ( prc_has_e ) then
4335 #ifdef _OPENACC
4336  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE, &
4337 #else
4338  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, &
4339 #endif
4340  comm_datatype_t, prc_next(prc_e), tag+70, &
4341  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4342  ireq = ireq + 1
4343  endif
4344  !$acc end host_data
4345 
4346  ! To NW HALO communicate
4347  if ( prc_has_n .AND. prc_has_w ) then
4348  tagc = 0
4349  do j = je-jhalo+1, je
4350  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4351  comm_datatype_t, prc_next(prc_nw), tag+tagc, &
4352  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4353  ireq = ireq + 1
4354  tagc = tagc + 1
4355  enddo
4356  else if ( prc_has_n ) then
4357  tagc = 10
4358  do j = je-jhalo+1, je
4359  call mpi_isend( var(1,j), ginfo(gid)%size2D_4C, &
4360  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4361  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4362  ireq = ireq + 1
4363  tagc = tagc + 1
4364  enddo
4365  else if ( prc_has_w ) then
4366  tagc = 20
4367  do j = je+1, ja
4368  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4369  comm_datatype_t, prc_next(prc_w), tag+tagc, &
4370  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4371  ireq = ireq + 1
4372  tagc = tagc + 1
4373  enddo
4374  endif
4375 
4376  ! To NE HALO communicate
4377  if ( prc_has_n .AND. prc_has_e ) then
4378  tagc = 10
4379  do j = je-jhalo+1, je
4380  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4381  comm_datatype_t, prc_next(prc_ne), tag+tagc, &
4382  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4383  ireq = ireq + 1
4384  tagc = tagc + 1
4385  enddo
4386  else if ( prc_has_n ) then
4387  tagc = 0
4388  do j = je-jhalo+1, je
4389  call mpi_isend( var(ie+1,j), ginfo(gid)%size2D_4C, &
4390  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4391  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4392  ireq = ireq + 1
4393  tagc = tagc + 1
4394  enddo
4395  else if ( prc_has_e ) then
4396  tagc = 30
4397  do j = je+1, ja
4398  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4399  comm_datatype_t, prc_next(prc_e), tag+tagc, &
4400  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4401  ireq = ireq + 1
4402  tagc = tagc + 1
4403  enddo
4404  endif
4405 
4406  ! To SW HALO communicate
4407  if ( prc_has_s .AND. prc_has_w ) then
4408  tagc = 20
4409  do j = js, js+jhalo-1
4410  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4411  comm_datatype_t, prc_next(prc_sw), tag+tagc, &
4412  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4413  ireq = ireq + 1
4414  tagc = tagc + 1
4415  enddo
4416  else if ( prc_has_s ) then
4417  tagc = 30
4418  do j = js, js+jhalo-1
4419  call mpi_isend( var(1,j), ginfo(gid)%size2D_4C, &
4420  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4421  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4422  ireq = ireq + 1
4423  tagc = tagc + 1
4424  enddo
4425  else if ( prc_has_w ) then
4426  tagc = 0
4427  do j = 1, js-1
4428  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4429  comm_datatype_t, prc_next(prc_w), tag+tagc, &
4430  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4431  ireq = ireq + 1
4432  tagc = tagc + 1
4433  enddo
4434  endif
4435 
4436  ! To SE HALO communicate
4437  if ( prc_has_s .AND. prc_has_e ) then
4438  tagc = 30
4439  do j = js, js+jhalo-1
4440  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4441  comm_datatype_t, prc_next(prc_se), tag+tagc, &
4442  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4443  ireq = ireq + 1
4444  tagc = tagc + 1
4445  enddo
4446  else if ( prc_has_s ) then
4447  tagc = 20
4448  do j = js, js+jhalo-1
4449  call mpi_isend( var(ie+1,j), ginfo(gid)%size2D_4C, &
4450  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4451  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4452  ireq = ireq + 1
4453  tagc = tagc + 1
4454  enddo
4455  else if ( prc_has_e ) then
4456  tagc = 10
4457  do j = 1, js-1
4458  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4459  comm_datatype_t, prc_next(prc_e), tag+tagc, &
4460  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4461  ireq = ireq + 1
4462  tagc = tagc + 1
4463  enddo
4464  endif
4465 
4466  !$acc end host_data
4467 
4468  end if
4469 
4470  endif
4471 
4472  ginfo(gid)%req_cnt(vid) = ireq - 1
4473 
4474  return
4475  end subroutine vars8_2d_mpi
4476 
4477  subroutine vars8_2d_mpi_onesided(var, gid, vid)
4478  use scale_prc_cartesc, only: &
4479  prc_twod
4480  implicit none
4481 
4482  real(RP), intent(inout) :: var(:,:)
4483  integer, intent(in) :: gid
4484  integer, intent(in) :: vid
4485 
4486  integer :: IA, IS, IE, IHALO
4487  integer :: JA, JS, JE, JHALO
4488 
4489  integer(kind=MPI_ADDRESS_KIND) :: disp
4490 
4491  integer :: ierr
4492  integer :: j
4493 #ifdef _OPENACC
4494  real(RP), pointer :: ptr(:,:)
4495 #endif
4496  !---------------------------------------------------------------------------
4497 
4498  ia = ginfo(gid)%IA
4499  is = ginfo(gid)%IS
4500  ie = ginfo(gid)%IE
4501  ihalo = ginfo(gid)%IHALO
4502  ja = ginfo(gid)%JA
4503  js = ginfo(gid)%JS
4504  je = ginfo(gid)%JE
4505  jhalo = ginfo(gid)%JHALO
4506 
4507  !$acc data copyin(var)
4508 
4509  call mpi_win_start( group_packwe, 0, ginfo(gid)%win_packWE(vid), ierr )
4510  call mpi_win_start( group_packns, 0, ginfo(gid)%win_packNS(vid), ierr )
4511 
4512  if ( comm_isallperiodic ) then
4513  !--- periodic condition
4514 
4515  !--- To 8-Direction HALO communicate
4516 
4517  !$acc host_data use_device(var)
4518 
4519  ! To N HALO communicate
4520  do j = je-jhalo+1, je
4521  disp = ihalo + ia * ( j - je+jhalo-1 )
4522  call mpi_put( var(is,j), ginfo(gid)%size2D_NS8, comm_datatype_t, &
4523  prc_next(prc_n), disp, ginfo(gid)%size2D_NS8, comm_datatype_t, &
4524  ginfo(gid)%win_packNS(vid), ierr )
4525  enddo
4526  ! To S HALO communicate
4527  do j = js, js+jhalo-1
4528  disp = ihalo + ia * ( j - js + jhalo )
4529  call mpi_put( var(is,j), ginfo(gid)%size2D_NS8, comm_datatype_t, &
4530  prc_next(prc_s), disp, ginfo(gid)%size2D_NS8, comm_datatype_t, &
4531  ginfo(gid)%win_packNS(vid), ierr )
4532  enddo
4533 
4534  !$acc end host_data
4535 
4536  if ( .not. prc_twod ) then
4537 
4538  call packwe_2d( ia, is, ie, ja, js, je, &
4539  ihalo, &
4540  var, gid, vid)
4541 
4542  !$acc host_data use_device(var)
4543 #ifdef _OPENACC
4544  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
4545  !$acc host_data use_device(ptr)
4546 #endif
4547 
4548  ! To W HALO communicate
4549  disp = 1
4550 #ifdef _OPENACC
4551  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE, comm_datatype_t, &
4552 #else
4553  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
4554 #endif
4555  prc_next(prc_w), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
4556  ginfo(gid)%win_packWE(vid), ierr )
4557  ! To E HALO communicate
4558  disp = 0
4559 #ifdef _OPENACC
4560  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE, comm_datatype_t, &
4561 #else
4562  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
4563 #endif
4564  prc_next(prc_e), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
4565  ginfo(gid)%win_packWE(vid), ierr )
4566  !$acc end host_data
4567  ! To NW HALO communicate
4568  do j = je-jhalo+1, je
4569  disp = ie + ia * ( j - je+jhalo-1 )
4570  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4571  prc_next(prc_nw), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4572  ginfo(gid)%win_packNS(vid), ierr )
4573  enddo
4574  ! To NE HALO communicate
4575  do j = je-jhalo+1, je
4576  disp = ia * ( j - je+jhalo-1 )
4577  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4578  prc_next(prc_ne), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4579  ginfo(gid)%win_packNS(vid), ierr )
4580  enddo
4581  ! To SW HALO communicate
4582  do j = js, js+jhalo-1
4583  disp = ie + ia * ( j - js + jhalo )
4584  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4585  prc_next(prc_sw), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4586  ginfo(gid)%win_packNS(vid), ierr )
4587  enddo
4588  ! To SE HALO communicate
4589  do j = js, js+jhalo-1
4590  disp = ia * ( j - js + jhalo )
4591  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4592  prc_next(prc_se), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4593  ginfo(gid)%win_packNS(vid), ierr )
4594  enddo
4595 
4596  !$acc end host_data
4597 
4598  end if
4599  else
4600  !--- non-periodic condition
4601 
4602  !$acc host_data use_device(var)
4603 
4604  ! To N HALO communicate
4605  if ( prc_has_n ) then
4606  do j = je-jhalo+1, je
4607  disp = ihalo + ia * ( j - je+jhalo-1 )
4608  call mpi_put( var(is,j), ginfo(gid)%size2D_NS8, comm_datatype_t, &
4609  prc_next(prc_n), disp, ginfo(gid)%size2D_NS8, comm_datatype_t, &
4610  ginfo(gid)%win_packNS(vid), ierr )
4611  enddo
4612  endif
4613  ! To S HALO communicate
4614  if ( prc_has_s ) then
4615  do j = js, js+jhalo-1
4616  disp = ihalo + ia * ( j - js + jhalo )
4617  call mpi_put( var(is,j), ginfo(gid)%size2D_NS8, comm_datatype_t, &
4618  prc_next(prc_s), disp, ginfo(gid)%size2D_NS8, comm_datatype_t, &
4619  ginfo(gid)%win_packNS(vid), ierr )
4620  enddo
4621  endif
4622 
4623  !$acc end host_data
4624 
4625  if ( .not. prc_twod ) then
4626 
4627  call packwe_2d( ia, is, ie, ja, js, je, &
4628  ihalo, &
4629  var, gid, vid)
4630 
4631  !$acc host_data use_device(var)
4632 #ifdef _OPENACC
4633  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
4634  !$acc host_data use_device(ptr)
4635 #endif
4636 
4637  ! To W HALO communicate
4638  if ( prc_has_w ) then
4639  disp = 1
4640 #ifdef _OPENACC
4641  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE, comm_datatype_t, &
4642 #else
4643  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
4644 #endif
4645  prc_next(prc_w), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
4646  ginfo(gid)%win_packWE(vid), ierr )
4647  endif
4648  ! To E HALO communicate
4649  if ( prc_has_e ) then
4650  disp = 0
4651 #ifdef _OPENACC
4652  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE, comm_datatype_t, &
4653 #else
4654  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
4655 #endif
4656  prc_next(prc_e), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
4657  ginfo(gid)%win_packWE(vid), ierr )
4658  endif
4659  !$acc end host_data
4660  ! To NW HALO communicate
4661  if ( prc_has_n .AND. prc_has_w ) then
4662  do j = je-jhalo+1, je
4663  disp = ie + ia * ( j - je+jhalo-1 )
4664  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4665  prc_next(prc_nw), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4666  ginfo(gid)%win_packNS(vid), ierr )
4667  enddo
4668  else if ( prc_has_n ) then
4669  do j = je-jhalo+1, je
4670  disp = ia * ( j - je+jhalo-1 )
4671  call mpi_put( var(1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4672  prc_next(prc_n), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4673  ginfo(gid)%win_packNS(vid), ierr )
4674  enddo
4675  else if ( prc_has_w ) then
4676  do j = je+1, ja
4677  disp = ie + ia * ( j - je-1 + jhalo )
4678  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4679  prc_next(prc_w), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4680  ginfo(gid)%win_packNS(vid), ierr )
4681  enddo
4682  endif
4683  ! To NE HALO communicate
4684  if ( prc_has_n .AND. prc_has_e ) then
4685  do j = je-jhalo+1, je
4686  disp = ia * ( j - je+jhalo-1 )
4687  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4688  prc_next(prc_ne), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4689  ginfo(gid)%win_packNS(vid), ierr )
4690  enddo
4691  else if ( prc_has_n ) then
4692  do j = je-jhalo+1, je
4693  disp = ie + ia * ( j - je+jhalo-1 )
4694  call mpi_put( var(ie+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4695  prc_next(prc_n), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4696  ginfo(gid)%win_packNS(vid), ierr )
4697  enddo
4698  else if ( prc_has_e ) then
4699  do j = je+1, ja
4700  disp = ia * ( j - je-1 + jhalo )
4701  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4702  prc_next(prc_e), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4703  ginfo(gid)%win_packNS(vid), ierr )
4704  enddo
4705  endif
4706  ! To SW HALO communicate
4707  if ( prc_has_s .AND. prc_has_w ) then
4708  do j = js, js+jhalo-1
4709  disp = ie + ia * ( j - js + jhalo )
4710  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4711  prc_next(prc_sw), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4712  ginfo(gid)%win_packNS(vid), ierr )
4713  enddo
4714  else if ( prc_has_s ) then
4715  do j = js, js+jhalo-1
4716  disp = ia * ( j - js + jhalo )
4717  call mpi_put( var(1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4718  prc_next(prc_s), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4719  ginfo(gid)%win_packNS(vid), ierr )
4720  enddo
4721  else if ( prc_has_w ) then
4722  do j = 1, js-1
4723  disp = ie + ia * ( j - 1 )
4724  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4725  prc_next(prc_w), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4726  ginfo(gid)%win_packNS(vid), ierr )
4727  enddo
4728  endif
4729  ! To SE HALO communicate
4730  if ( prc_has_s .AND. prc_has_e ) then
4731  do j = js, js+jhalo-1
4732  disp = ia * ( j - js + jhalo )
4733  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4734  prc_next(prc_se), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4735  ginfo(gid)%win_packNS(vid), ierr )
4736  enddo
4737  else if ( prc_has_s ) then
4738  do j = js, js+jhalo-1
4739  disp = ie + ia * ( j - js + jhalo )
4740  call mpi_put( var(ie+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4741  prc_next(prc_s), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4742  ginfo(gid)%win_packNS(vid), ierr )
4743  enddo
4744  else if ( prc_has_e ) then
4745  do j = 1, js-1
4746  disp = ia * ( j - 1 )
4747  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4748  prc_next(prc_e), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4749  ginfo(gid)%win_packNS(vid), ierr )
4750  enddo
4751  endif
4752 
4753  !$acc end host_data
4754  end if
4755 
4756  endif
4757 
4758  call mpi_win_complete( ginfo(gid)%win_packWE(vid), ierr )
4759  call mpi_win_complete( ginfo(gid)%win_packNS(vid), ierr )
4760 
4761  !$acc end data
4762 
4763  return
4764  end subroutine vars8_2d_mpi_onesided
4765 
4766  subroutine vars_3d_mpi_pc(var, gid, vid)
4767  use scale_prc, only: &
4768  prc_abort
4769  use scale_prc_cartesc, only: &
4770  prc_twod
4771  implicit none
4772  real(RP), intent(inout) :: var(:,:,:)
4773  integer, intent(in) :: gid
4774  integer, intent(in) :: vid
4775 
4776  integer :: KA
4777  integer :: IA, IS, IE
4778  integer :: JA, JS, JE
4779  integer :: IHALO
4780 
4781  integer :: ierr
4782  !---------------------------------------------------------------------------
4783 
4784 #ifdef DEBUG
4785  if ( ginfo(gid)%use_packbuf(ginfo(gid)%packid(vid)) ) then
4786  log_error("vars_3D_mpi_pc",*) 'packing buffer is already used', vid, ginfo(gid)%packid(vid)
4787  call prc_abort
4788  end if
4789  ginfo(gid)%use_packbuf(ginfo(gid)%packid(vid)) = .true.
4790 #endif
4791 
4792 #ifdef _OPENACC
4793  if ( ginfo(gid)%device_alloc(vid+comm_vsize_max) ) then
4794  !$acc update device(var)
4795  end if
4796 #endif
4797 
4798  if ( .not. prc_twod ) then
4799  ka = ginfo(gid)%KA
4800  ia = ginfo(gid)%IA
4801  is = ginfo(gid)%IS
4802  ie = ginfo(gid)%IE
4803  ja = ginfo(gid)%JA
4804  js = ginfo(gid)%JS
4805  je = ginfo(gid)%JE
4806  ihalo = ginfo(gid)%IHALO
4807  call packwe_3d( ka, ia, is, ie, ja, js, je, &
4808  ihalo, &
4809  var, gid, ginfo(gid)%packid(vid))
4810  !$acc wait
4811  end if
4812 
4813  call mpi_startall(ginfo(gid)%preq_cnt(vid), ginfo(gid)%preq_list(1:ginfo(gid)%preq_cnt(vid),vid), ierr)
4814 
4815  return
4816  end subroutine vars_3d_mpi_pc
4817 
4818  subroutine wait_3d_mpi(var, gid, vid)
4819  use scale_prc_cartesc, only: &
4820  prc_twod
4821  implicit none
4822  real(RP), intent(inout) :: var(:,:,:)
4823  integer, intent(in) :: gid
4824  integer, intent(in) :: vid
4825 
4826  integer :: KA
4827  integer :: IA, IS, IE
4828  integer :: JA, JS, JE
4829  integer :: IHALO
4830 
4831  integer :: ierr
4832  !---------------------------------------------------------------------------
4833 
4834  !--- wait packets
4835  call mpi_waitall( ginfo(gid)%req_cnt (vid), &
4836  ginfo(gid)%req_list(1:ginfo(gid)%req_cnt(vid),vid), &
4837  mpi_statuses_ignore, &
4838  ierr )
4839  if ( .not. prc_twod ) then
4840  ka = ginfo(gid)%KA
4841  ia = ginfo(gid)%IA
4842  is = ginfo(gid)%IS
4843  ie = ginfo(gid)%IE
4844  ja = ginfo(gid)%JA
4845  js = ginfo(gid)%JS
4846  je = ginfo(gid)%JE
4847  ihalo = ginfo(gid)%IHALO
4848  call unpackwe_3d( ka, ia, is, ie, ja, js, je, &
4849  ihalo, &
4850  var, ginfo(gid)%recvpack_WE2P(:,:,vid) )
4851  !$acc wait
4852  end if
4853 
4854 #ifdef DEBUG
4855  ginfo(gid)%use_packbuf(vid) = .false.
4856 #endif
4857 
4858  return
4859  end subroutine wait_3d_mpi
4860 
4861  subroutine wait_3d_mpi_onesided(var, gid, vid)
4862  use scale_prc_cartesc, only: &
4863  prc_twod
4864  implicit none
4865  real(RP), intent(inout) :: var(:,:,:)
4866  integer, intent(in) :: gid
4867  integer, intent(in) :: vid
4868 
4869  integer :: KA
4870  integer :: IA, IS, IE
4871  integer :: JA, JS, JE
4872  integer :: IHALO, JHALO
4873 
4874  real(RP), pointer :: pack(:)
4875 
4876  integer :: ierr
4877  !---------------------------------------------------------------------------
4878 
4879  ka = ginfo(gid)%KA
4880  ia = ginfo(gid)%IA
4881  is = ginfo(gid)%IS
4882  ie = ginfo(gid)%IE
4883  ja = ginfo(gid)%JA
4884  js = ginfo(gid)%JS
4885  je = ginfo(gid)%JE
4886  ihalo = ginfo(gid)%IHALO
4887  jhalo = ginfo(gid)%JHALO
4888 
4889  call mpi_win_wait( ginfo(gid)%win_packWE(vid), ierr )
4890  if ( .not. prc_twod ) then
4891  call c_f_pointer( ginfo(gid)%recvbuf_WE(vid), pack, (/ginfo(gid)%size2D_WE*ka*2/) )
4892  call unpackwe_3d( ka, ia, is, ie, ja, js, je, &
4893  ihalo, &
4894  var, pack )
4895  end if
4896 
4897  call mpi_win_wait( ginfo(gid)%win_packNS(vid), ierr )
4898  call c_f_pointer( ginfo(gid)%recvbuf_NS(vid), pack, (/ginfo(gid)%size2D_NS4*ka*2/) )
4899  call unpackns_3d( ka, ia, is, ie, ja, js, je, &
4900  jhalo, &
4901  var, pack )
4902 
4903  !$acc wait
4904 
4905  call mpi_win_post( group_packwe, mpi_mode_nostore, ginfo(gid)%win_packWE(vid), ierr )
4906  call mpi_win_post( group_packns, mpi_mode_nostore, ginfo(gid)%win_packNS(vid), ierr )
4907 
4908  return
4909  end subroutine wait_3d_mpi_onesided
4910 
4911  subroutine wait_2d_mpi(var, gid, vid)
4912  use scale_prc_cartesc, only: &
4913  prc_twod
4914  implicit none
4915  real(RP), intent(inout) :: var(:,:)
4916  integer, intent(in) :: gid
4917  integer, intent(in) :: vid
4918 
4919  integer :: KA
4920  integer :: IA, IS, IE
4921  integer :: JA, JS, JE
4922  integer :: IHALO
4923 
4924  integer :: ierr
4925  !---------------------------------------------------------------------------
4926 
4927  !--- wait packets
4928  call mpi_waitall( ginfo(gid)%req_cnt(vid), &
4929  ginfo(gid)%req_list(1:ginfo(gid)%req_cnt(vid),vid), &
4930  mpi_statuses_ignore, &
4931  ierr )
4932  if ( .not. prc_twod ) then
4933  ka = ginfo(gid)%KA
4934  ia = ginfo(gid)%IA
4935  is = ginfo(gid)%IS
4936  ie = ginfo(gid)%IE
4937  ja = ginfo(gid)%JA
4938  js = ginfo(gid)%JS
4939  je = ginfo(gid)%JE
4940  ihalo = ginfo(gid)%IHALO
4941  call unpackwe_2d( ka, ia, is, ie, ja, js, je, &
4942  ihalo, &
4943  var, ginfo(gid)%recvpack_WE2P(:,:,vid) )
4944  end if
4945 
4946 #ifdef DEBUG
4947  ginfo(gid)%use_packbuf(vid) = .false.
4948 #endif
4949 
4950  return
4951  end subroutine wait_2d_mpi
4952 
4953  subroutine wait_2d_mpi_onesided(var, gid, vid)
4954  use scale_prc_cartesc, only: &
4955  prc_twod
4956  implicit none
4957  real(RP), intent(inout) :: var(:,:)
4958  integer, intent(in) :: gid
4959  integer, intent(in) :: vid
4960 
4961  integer :: KA
4962  integer :: IA, IS, IE
4963  integer :: JA, JS, JE
4964  integer :: IHALO, JHALO
4965 
4966  real(RP), pointer :: pack(:)
4967 
4968  integer :: ierr
4969  !---------------------------------------------------------------------------
4970 
4971  ka = ginfo(gid)%KA
4972  ia = ginfo(gid)%IA
4973  is = ginfo(gid)%IS
4974  ie = ginfo(gid)%IE
4975  ja = ginfo(gid)%JA
4976  js = ginfo(gid)%JS
4977  je = ginfo(gid)%JE
4978  ihalo = ginfo(gid)%IHALO
4979  jhalo = ginfo(gid)%JHALO
4980 
4981  call mpi_win_wait( ginfo(gid)%win_packWE(vid), ierr )
4982  if ( .not. prc_twod ) then
4983  call c_f_pointer( ginfo(gid)%recvbuf_WE(vid), pack, (/ginfo(gid)%size2D_WE*ka*2/) )
4984  call unpackwe_2d( ka, ia, is, ie, ja, js, je, &
4985  ihalo, &
4986  var, pack )
4987  end if
4988 
4989  call mpi_win_wait( ginfo(gid)%win_packNS(vid), ierr )
4990  call c_f_pointer( ginfo(gid)%recvbuf_NS(vid), pack, (/ginfo(gid)%size2D_NS4*ka*2/) )
4991  call unpackns_2d( ia, is, ie, ja, js, je, &
4992  jhalo, &
4993  var, pack )
4994 
4995  call mpi_win_post( group_packwe, mpi_mode_nostore, ginfo(gid)%win_packWE(vid), ierr )
4996  call mpi_win_post( group_packns, mpi_mode_nostore, ginfo(gid)%win_packNS(vid), ierr )
4997 
4998  return
4999  end subroutine wait_2d_mpi_onesided
5000 
5001  subroutine wait_3d_mpi_pc(var, gid, vid)
5002  use scale_prc_cartesc, only: &
5003  prc_twod
5004  implicit none
5005  real(RP), intent(inout) :: var(:,:,:)
5006  integer, intent(in) :: gid
5007  integer, intent(in) :: vid
5008 
5009  integer :: KA
5010  integer :: IA, IS, IE
5011  integer :: JA, JS, JE
5012  integer :: IHALO
5013 
5014  integer :: pid
5015  integer :: ierr
5016 
5017  !--- wait packets
5018  call mpi_waitall( ginfo(gid)%preq_cnt (vid), &
5019  ginfo(gid)%preq_list(1:ginfo(gid)%preq_cnt(vid),vid), &
5020  mpi_statuses_ignore, &
5021  ierr )
5022  if ( .not. prc_twod ) then
5023  ka = ginfo(gid)%KA
5024  ia = ginfo(gid)%IA
5025  is = ginfo(gid)%IS
5026  ie = ginfo(gid)%IE
5027  ja = ginfo(gid)%JA
5028  js = ginfo(gid)%JS
5029  je = ginfo(gid)%JE
5030  ihalo = ginfo(gid)%IHALO
5031  pid = ginfo(gid)%packid(vid)
5032  call unpackwe_3d( ka, ia, is, ie, ja, js, je, &
5033  ihalo, &
5034  var, ginfo(gid)%recvpack_WE2P(:,:,pid) )
5035  !$acc wait
5036  end if
5037 
5038 #ifdef DEBUG
5039  ginfo(gid)%use_packbuf(ginfo(gid)%packid(vid)) = .false.
5040 #endif
5041 
5042 #ifdef _OPENACC
5043  if ( ginfo(gid)%device_alloc(vid+comm_vsize_max) ) then
5044  !$acc update host(var)
5045  end if
5046 #endif
5047 
5048  return
5049  end subroutine wait_3d_mpi_pc
5050 
5051  subroutine packwe_3d( KA, IA, IS, IE, JA, JS, JE, &
5052  IHALO, &
5053  var, gid, vid)
5054  implicit none
5055  integer, intent(in) :: KA
5056  integer, intent(in) :: IA, IS, IE
5057  integer, intent(in) :: JA, JS, JE
5058  integer, intent(in) :: IHALO
5059  real(RP), intent(in) :: var(KA,IA,JA)
5060  integer, intent(in) :: gid
5061  integer, intent(in) :: vid
5062 
5063  integer :: k, i, j, n
5064 
5065 #ifdef _OPENACC
5066  real(RP), pointer :: ptr(:,:,:)
5067  ptr => ginfo(gid)%sendpack_P2WE
5068 #endif
5069 
5070  !$acc data copyin(var) if(acc_is_present(var))
5071 
5072  call prof_rapstart('COMM_pack', 3)
5073 
5074  if ( prc_has_w ) then
5075  !--- packing packets to West
5076  !$omp parallel do private(i,j,k,n) OMP_SCHEDULE_ collapse(2)
5077  !$acc parallel if(acc_is_present(var)) async
5078  !$acc loop collapse(2) gang
5079  do j = js, je
5080  do i = is, is+ihalo-1
5081  !$acc loop independent vector
5082  do k = 1, ka
5083  n = (j-js) * ka * ihalo &
5084  + (i-is) * ka &
5085  + k
5086 #ifdef _OPENACC
5087  ptr(n,1,vid) = var(k,i,j)
5088 #else
5089  ginfo(gid)%sendpack_P2WE(n,1,vid) = var(k,i,j)
5090 #endif
5091  enddo
5092  enddo
5093  enddo
5094  !$acc end parallel
5095  end if
5096 
5097  if ( prc_has_e ) then
5098  !--- packing packets to East
5099  !$omp parallel do private(i,j,k,n) OMP_SCHEDULE_ collapse(2)
5100  !$acc parallel if(acc_is_present(var)) async
5101  !$acc loop collapse(2) gang
5102  do j = js, je
5103  do i = ie-ihalo+1, ie
5104  !$acc loop independent vector
5105  do k = 1, ka
5106  n = (j-js) * ka * ihalo &
5107  + (i-ie+ihalo-1) * ka &
5108  + k
5109 #ifdef _OPENACC
5110  ptr(n,2,vid) = var(k,i,j)
5111 #else
5112  ginfo(gid)%sendpack_P2WE(n,2,vid) = var(k,i,j)
5113 #endif
5114  enddo
5115  enddo
5116  enddo
5117  !$acc end parallel
5118  end if
5119 
5120  call prof_rapend('COMM_pack', 3)
5121 
5122  !$acc end data
5123 
5124  return
5125  end subroutine packwe_3d
5126 
5127  subroutine packwe_2d( IA, IS, IE, JA, JS, JE, &
5128  IHALO, &
5129  var, gid, vid)
5130  implicit none
5131  integer, intent(in) :: IA, IS, IE
5132  integer, intent(in) :: JA, JS, JE
5133  integer, intent(in) :: IHALO
5134  real(RP), intent(in) :: var(IA,JA)
5135  integer, intent(in) :: vid
5136  integer, intent(in) :: gid
5137 
5138  integer :: i, j, n
5139 
5140 #ifdef _OPENACC
5141  real(RP), pointer :: ptr(:,:,:)
5142  ptr => ginfo(gid)%sendpack_P2WE
5143 #endif
5144  !$acc data copyin(var) if(acc_is_present(var))
5145 
5146  call prof_rapstart('COMM_pack', 3)
5147 
5148  if ( prc_has_w ) then
5149  !--- To 4-Direction HALO communicate
5150  !--- packing packets to West
5151  !$omp parallel do private(i,j,n) OMP_SCHEDULE_
5152  !$acc kernels if(acc_is_present(var)) async
5153  !$acc loop independent
5154  do j = js, je
5155  !$acc loop independent
5156  do i = is, is+ihalo-1
5157  n = (j-js) * ihalo &
5158  + (i-is) + 1
5159 #ifdef _OPENACC
5160  ptr(n,1,vid) = var(i,j)
5161 #else
5162  ginfo(gid)%sendpack_P2WE(n,1,vid) = var(i,j)
5163 #endif
5164  enddo
5165  enddo
5166  !$acc end kernels
5167  end if
5168 
5169  if ( prc_has_e ) then
5170  !--- packing packets to East
5171  !$omp parallel do private(i,j,n) OMP_SCHEDULE_
5172  !$acc kernels if(acc_is_present(var)) async
5173  !$acc loop independent
5174  do j = js, je
5175  !$acc loop independent
5176  do i = ie-ihalo+1, ie
5177  n = (j-js) * ihalo &
5178  + (i-ie+ihalo-1) + 1
5179 #ifdef _OPENACC
5180  ptr(n,2,vid) = var(i,j)
5181 #else
5182  ginfo(gid)%sendpack_P2WE(n,2,vid) = var(i,j)
5183 #endif
5184  enddo
5185  enddo
5186  !$acc end kernels
5187  end if
5188 
5189  !$acc wait
5190 
5191  call prof_rapend('COMM_pack', 3)
5192 
5193  !$acc end data
5194 
5195  return
5196  end subroutine packwe_2d
5197 
5198  subroutine unpackwe_3d( KA, IA, IS, IE, JA, JS, JE, &
5199  IHALO, &
5200  var, buf )
5201  implicit none
5202  integer, intent(in) :: KA
5203  integer, intent(in) :: IA, IS, IE
5204  integer, intent(in) :: JA, JS, JE
5205  integer, intent(in) :: IHALO
5206  real(RP), intent(inout) :: var(KA,IA,JA)
5207  real(RP), intent(in) :: buf(KA,IHALO,JS:JE,2)
5208 
5209  integer :: i, j, k
5210  !---------------------------------------------------------------------------
5211 
5212  !$acc data copy(var) copyin(buf) if(acc_is_present(var))
5213 
5214  call prof_rapstart('COMM_unpack', 3)
5215 
5216  if ( prc_has_e ) then
5217  !--- unpacking packets from East
5218  !$omp parallel do private(i,j,k) OMP_SCHEDULE_ collapse(2)
5219  !$acc parallel if(acc_is_present(var)) async
5220  !$acc loop collapse(2) gang
5221  do j = js, je
5222  do i = ie+1, ia
5223  !$acc loop vector
5224  do k = 1, ka
5225  var(k,i,j) = buf(k,i-ie,j,2)
5226  enddo
5227  enddo
5228  enddo
5229  !$acc end parallel
5230  end if
5231 
5232  if ( prc_has_w ) then
5233  !--- unpacking packets from West
5234  !$omp parallel do private(i,j,k) OMP_SCHEDULE_ collapse(2)
5235  !$acc parallel if(acc_is_present(var)) async
5236  !$acc loop collapse(2) gang
5237  do j = js, je
5238  do i = 1, is-1
5239  !$acc loop vector
5240  do k = 1, ka
5241  var(k,i,j) = buf(k,i,j,1)
5242  enddo
5243  enddo
5244  enddo
5245  !$acc end parallel
5246  end if
5247 
5248  call prof_rapend('COMM_unpack', 3)
5249 
5250  !$acc end data
5251 
5252  return
5253  end subroutine unpackwe_3d
5254 
5255  subroutine unpackwe_2d( KA, IA, IS, IE, JA, JS, JE, &
5256  IHALO, &
5257  var, buf )
5258  implicit none
5259  integer, intent(in) :: KA
5260  integer, intent(in) :: IA, IS, IE
5261  integer, intent(in) :: JA, JS, JE
5262  integer, intent(in) :: IHALO
5263  real(RP), intent(inout) :: var(IA,JA)
5264  real(RP), intent(in) :: buf(IHALO,JS:JE,KA,2)
5265 
5266  integer :: i, j
5267  !---------------------------------------------------------------------------
5268 
5269  !$acc data copy(var) copyin(buf) if(acc_is_present(var))
5270 
5271  call prof_rapstart('COMM_unpack', 3)
5272 
5273  if( prc_has_e ) then
5274  !--- unpacking packets from East
5275  !$omp parallel do private(i,j) OMP_SCHEDULE_
5276  !$acc kernels if(acc_is_present(var)) async
5277  do j = js, je
5278  do i = ie+1, ie+ihalo
5279  var(i,j) = buf(i-ie,j,1,2)
5280  enddo
5281  enddo
5282  !$acc end kernels
5283  end if
5284 
5285  if( prc_has_w ) then
5286  !--- unpacking packets from West
5287  !$omp parallel do private(i,j) OMP_SCHEDULE_
5288  !$acc kernels if(acc_is_present(var)) async
5289  do j = js, je
5290  do i = is-ihalo, is-1
5291  var(i,j) = buf(i,j,1,1)
5292  enddo
5293  enddo
5294  !$acc end kernels
5295  end if
5296 
5297  !$acc wait
5298 
5299  call prof_rapend('COMM_unpack', 3)
5300 
5301  !$acc end data
5302 
5303  return
5304  end subroutine unpackwe_2d
5305 
5306  subroutine unpackns_3d( KA, IA, IS, IE, JA, JS, JE, &
5307  JHALO, &
5308  var, buf )
5309  implicit none
5310  integer, intent(in) :: KA
5311  integer, intent(in) :: IA, IS, IE
5312  integer, intent(in) :: JA, JS, JE
5313  integer, intent(in) :: JHALO
5314  real(RP), intent(inout) :: var(KA,IA,JA)
5315  real(RP), intent(in) :: buf(KA,IA,JHALO,2)
5316 
5317  integer :: i, j, k
5318  !---------------------------------------------------------------------------
5319 
5320  !$acc data copy(var) copyin(buf)
5321 
5322  call prof_rapstart('COMM_unpack', 3)
5323 
5324  if ( prc_has_s ) then
5325  !--- unpacking packets from S, SW, and SE
5326  !$omp parallel do private(i,j,k) OMP_SCHEDULE_ collapse(2)
5327  !$acc kernels async
5328  do j = 1, js-1
5329  do i = 1, ia
5330  do k = 1, ka
5331  var(k,i,j) = buf(k,i,j,1)
5332  enddo
5333  enddo
5334  enddo
5335  !$acc end kernels
5336  else
5337  if ( prc_has_w ) then
5338  !--- unpacking packets from SW
5339  !$omp parallel do private(i,j,k) OMP_SCHEDULE_ collapse(2)
5340  !$acc kernels async
5341  do j = 1, js-1
5342  do i = 1, is-1
5343  do k = 1, ka
5344  var(k,i,j) = buf(k,i,j,1)
5345  enddo
5346  enddo
5347  enddo
5348  !$acc end kernels
5349  end if
5350  if ( prc_has_e ) then
5351  !--- unpacking packets from SE
5352  !$omp parallel do private(i,j,k) OMP_SCHEDULE_ collapse(2)
5353  !$acc kernels async
5354  do j = 1, js-1
5355  do i = ie+1, ia
5356  do k = 1, ka
5357  var(k,i,j) = buf(k,i,j,1)
5358  enddo
5359  enddo
5360  enddo
5361  !$acc end kernels
5362  end if
5363  end if
5364 
5365  if ( prc_has_n ) then
5366  !--- unpacking packets from N, NW, and NE
5367  !$omp parallel do private(i,j,k) OMP_SCHEDULE_ collapse(2)
5368  !$acc kernels async
5369  do j = je+1, ja
5370  do i = 1, ia
5371  do k = 1, ka
5372  var(k,i,j) = buf(k,i,j-je,2)
5373  enddo
5374  enddo
5375  enddo
5376  !$acc end kernels
5377  else
5378  if ( prc_has_w ) then
5379  !--- unpacking packets from NW
5380  !$omp parallel do private(i,j,k) OMP_SCHEDULE_ collapse(2)
5381  !$acc kernels async
5382  do j = je+1, ja
5383  do i = 1, is-1
5384  do k = 1, ka
5385  var(k,i,j) = buf(k,i,j-je,2)
5386  enddo
5387  enddo
5388  enddo
5389  !$acc end kernels
5390  end if
5391  if ( prc_has_e ) then
5392  !--- unpacking packets from NE
5393  !$omp parallel do private(i,j,k) OMP_SCHEDULE_ collapse(2)
5394  !$acc kernels async
5395  do j = je+1, ja
5396  do i = ie+1, ia
5397  do k = 1, ka
5398  var(k,i,j) = buf(k,i,j-je,2)
5399  enddo
5400  enddo
5401  enddo
5402  !$acc end kernels
5403  end if
5404  end if
5405 
5406  !$acc wait
5407 
5408  call prof_rapend('COMM_unpack', 3)
5409 
5410  !$acc end data
5411 
5412  return
5413  end subroutine unpackns_3d
5414 
5415  subroutine unpackns_2d( IA, IS, IE, JA, JS, JE, &
5416  JHALO, &
5417  var, buf )
5418  implicit none
5419  integer, intent(in) :: IA, IS, IE
5420  integer, intent(in) :: JA, JS, JE
5421  integer, intent(in) :: JHALO
5422  real(RP), intent(inout) :: var(IA,JA)
5423  real(RP), intent(in) :: buf(IA,JHALO,2)
5424 
5425  integer :: i, j
5426  !---------------------------------------------------------------------------
5427 
5428  !$acc data copy(var) copyin(buf)
5429 
5430  call prof_rapstart('COMM_unpack', 3)
5431 
5432  if ( prc_has_s ) then
5433  !--- unpacking packets from S, SW, and SE
5434  !$omp parallel do private(i,j) OMP_SCHEDULE_
5435  !$acc kernels async
5436  do j = 1, js-1
5437  do i = 1, ia
5438  var(i,j) = buf(i,j,1)
5439  enddo
5440  enddo
5441  !$acc end kernels
5442  else
5443  if ( prc_has_w ) then
5444  !--- unpacking packets from SW
5445  !$omp parallel do private(i,j) OMP_SCHEDULE_
5446  !$acc kernels async
5447  do j = 1, js-1
5448  do i = 1, is-1
5449  var(i,j) = buf(i,j,1)
5450  enddo
5451  enddo
5452  !$acc end kernels
5453  end if
5454  if ( prc_has_e ) then
5455  !--- unpacking packets from SE
5456  !$omp parallel do private(i,j) OMP_SCHEDULE_
5457  !$acc kernels async
5458  do j = 1, js-1
5459  do i = ie+1, ia
5460  var(i,j) = buf(i,j,1)
5461  enddo
5462  enddo
5463  !$acc end kernels
5464  end if
5465  end if
5466 
5467  if ( prc_has_n ) then
5468  !--- unpacking packets from N, NW, and NE
5469  !$omp parallel do private(i,j) OMP_SCHEDULE_
5470  !$acc kernels async
5471  do j = je+1, ja
5472  do i = 1, ia
5473  var(i,j) = buf(i,j-je,2)
5474  enddo
5475  enddo
5476  !$acc end kernels
5477  else
5478  if ( prc_has_w ) then
5479  !--- unpacking packets from NW
5480  !$omp parallel do private(i,j) OMP_SCHEDULE_
5481  !$acc kernels async
5482  do j = je+1, ja
5483  do i = 1, is-1
5484  var(i,j) = buf(i,j-je,2)
5485  enddo
5486  enddo
5487  !$acc end kernels
5488  end if
5489  if ( prc_has_e ) then
5490  !--- unpacking packets from NE
5491  !$omp parallel do private(i,j) OMP_SCHEDULE_
5492  !$acc kernels async
5493  do j = je+1, ja
5494  do i = ie+1, ia
5495  var(i,j) = buf(i,j-je,2)
5496  enddo
5497  enddo
5498  !$acc end kernels
5499  end if
5500  end if
5501 
5502  !$acc wait
5503 
5504  call prof_rapend('COMM_unpack', 3)
5505 
5506  !$acc end data
5507 
5508  return
5509  end subroutine unpackns_2d
5510 
5511  subroutine copy_boundary_3d(var, gid)
5512  use scale_prc_cartesc, only: &
5513  prc_twod
5514  implicit none
5515 
5516  real(RP), intent(inout) :: var(:,:,:)
5517  integer, intent(in) :: gid
5518 
5519  integer :: KA
5520  integer :: IS, IE, IHALO
5521  integer :: JS, JE, JHALO
5522 
5523  integer :: k, i, j
5524  !---------------------------------------------------------------------------
5525 
5526  !$acc data copy(var)
5527 
5528  ka = ginfo(gid)%KA
5529  is = ginfo(gid)%IS
5530  ie = ginfo(gid)%IE
5531  ihalo = ginfo(gid)%IHALO
5532  js = ginfo(gid)%JS
5533  je = ginfo(gid)%JE
5534  jhalo = ginfo(gid)%JHALO
5535 
5536  !$omp parallel
5537 
5538  !--- copy inner data to HALO(North)
5539  if ( .NOT. prc_has_n ) then
5540  !$acc kernels async
5541  do j = je+1, je+jhalo
5542  !$omp do
5543  do i = is, ie
5544  do k = 1, ka
5545  var(k,i,j) = var(k,i,je)
5546  enddo
5547  enddo
5548  !$omp end do nowait
5549  enddo
5550  !$acc end kernels
5551  endif
5552 
5553  !--- copy inner data to HALO(South)
5554  if ( .NOT. prc_has_s ) then
5555  !$acc kernels async
5556  !$acc loop independent
5557  do j = js-jhalo, js-1
5558  !$omp do
5559  do i = is, ie
5560  do k = 1, ka
5561  var(k,i,j) = var(k,i,js)
5562  enddo
5563  enddo
5564  !$omp end do nowait
5565  enddo
5566  !$acc end kernels
5567  endif
5568 
5569  if ( .not. prc_twod ) then
5570 
5571  !--- copy inner data to HALO(East)
5572  if ( .NOT. prc_has_e ) then
5573  !$acc kernels async
5574  !$omp do
5575  do j = js, je
5576  do i = ie+1, ie+ihalo
5577  do k = 1, ka
5578  var(k,i,j) = var(k,ie,j)
5579  enddo
5580  enddo
5581  enddo
5582  !$omp end do nowait
5583  !$acc end kernels
5584  end if
5585 
5586  !--- copy inner data to HALO(West)
5587  if ( .NOT. prc_has_w ) then
5588  !$acc kernels async
5589  !$omp do
5590  do j = js, je
5591  !$acc loop independent
5592  do i = is-ihalo, is-1
5593  var(:,i,j) = var(:,is,j)
5594  enddo
5595  enddo
5596  !$omp end do nowait
5597  !$acc end kernels
5598  end if
5599 
5600  !--- copy inner data to HALO(NorthWest)
5601  if ( .NOT. prc_has_n .AND. &
5602  .NOT. prc_has_w ) then
5603  !$acc kernels async
5604  do j = je+1, je+jhalo
5605  !$acc loop independent
5606  do i = is-ihalo, is-1
5607  do k = 1, ka
5608  var(k,i,j) = var(k,is,je)
5609  enddo
5610  enddo
5611  enddo
5612  !$acc end kernels
5613  elseif( .NOT. prc_has_n ) then
5614  !$acc kernels async
5615  do j = je+1, je+jhalo
5616  do i = is-ihalo, is-1
5617  do k = 1, ka
5618  var(k,i,j) = var(k,i,je)
5619  enddo
5620  enddo
5621  enddo
5622  !$acc end kernels
5623  elseif( .NOT. prc_has_w ) then
5624  !$acc kernels async
5625  do j = je+1, je+jhalo
5626  !$acc loop independent
5627  do i = is-ihalo, is-1
5628  do k = 1, ka
5629  var(k,i,j) = var(k,is,j)
5630  enddo
5631  enddo
5632  enddo
5633  !$acc end kernels
5634  endif
5635 
5636  !--- copy inner data to HALO(SouthWest)
5637  if ( .NOT. prc_has_s .AND. &
5638  .NOT. prc_has_w ) then
5639  !$acc kernels async
5640  !$acc loop independent
5641  do j = js-jhalo, js-1
5642  !$acc loop independent
5643  do i = is-ihalo, is-1
5644  do k = 1, ka
5645  var(k,i,j) = var(k,is,js)
5646  enddo
5647  enddo
5648  enddo
5649  !$acc end kernels
5650  elseif( .NOT. prc_has_s ) then
5651  !$acc kernels async
5652  !$acc loop independent
5653  do j = js-jhalo, js-1
5654  do i = is-ihalo, is-1
5655  do k = 1, ka
5656  var(k,i,j) = var(k,i,js)
5657  enddo
5658  enddo
5659  enddo
5660  !$acc end kernels
5661  elseif( .NOT. prc_has_w ) then
5662  !$acc kernels async
5663  do j = js-jhalo, js-1
5664  !$acc loop independent
5665  do i = is-ihalo, is-1
5666  do k = 1, ka
5667  var(k,i,j) = var(k,is,j)
5668  enddo
5669  enddo
5670  enddo
5671  !$acc end kernels
5672  endif
5673 
5674  !--- copy inner data to HALO(NorthEast)
5675  if ( .NOT. prc_has_n .AND. &
5676  .NOT. prc_has_e ) then
5677  !$acc kernels async
5678  do j = je+1, je+jhalo
5679  do i = ie+1, ie+ihalo
5680  do k = 1, ka
5681  var(k,i,j) = var(k,ie,je)
5682  enddo
5683  enddo
5684  enddo
5685  !$acc end kernels
5686  elseif( .NOT. prc_has_n ) then
5687  !$acc kernels async
5688  do j = je+1, je+jhalo
5689  do i = ie+1, ie+ihalo
5690  do k = 1, ka
5691  var(k,i,j) = var(k,i,je)
5692  enddo
5693  enddo
5694  enddo
5695  !$acc end kernels
5696  elseif( .NOT. prc_has_e ) then
5697  !$acc kernels async
5698  do j = je+1, je+jhalo
5699  do i = ie+1, ie+ihalo
5700  do k = 1, ka
5701  var(k,i,j) = var(k,ie,j)
5702  enddo
5703  enddo
5704  enddo
5705  !$acc end kernels
5706  endif
5707 
5708  !--- copy inner data to HALO(SouthEast)
5709  if ( .NOT. prc_has_s .AND. &
5710  .NOT. prc_has_e ) then
5711  !$acc kernels async
5712  do j = js-jhalo, js-1
5713  do i = ie+1, ie+ihalo
5714  do k = 1, ka
5715  var(k,i,j) = var(k,ie,js)
5716  enddo
5717  enddo
5718  enddo
5719  !$acc end kernels
5720  elseif( .NOT. prc_has_s ) then
5721  !$acc kernels async
5722  !$acc loop independent
5723  do j = js-jhalo, js-1
5724  do i = ie+1, ie+ihalo
5725  do k = 1, ka
5726  var(k,i,j) = var(k,i,js)
5727  enddo
5728  enddo
5729  enddo
5730  !$acc end kernels
5731  elseif( .NOT. prc_has_e ) then
5732  !$acc kernels async
5733  do j = js-jhalo, js-1
5734  do i = ie+1, ie+ihalo
5735  do k = 1, ka
5736  var(k,i,j) = var(k,ie,j)
5737  enddo
5738  enddo
5739  enddo
5740  !$acc end kernels
5741  endif
5742 
5743  end if
5744 
5745  !$omp end parallel
5746 
5747  !$acc wait
5748 
5749  !$acc end data
5750 
5751  return
5752  end subroutine copy_boundary_3d
5753 
5754  subroutine copy_boundary_2d(var, gid)
5755  use scale_prc_cartesc, only: &
5756  prc_twod
5757  implicit none
5758 
5759  real(RP), intent(inout) :: var(:,:)
5760  integer, intent(in) :: gid
5761 
5762  integer :: IS, IE, IHALO
5763  integer :: JS, JE, JHALO
5764 
5765  integer :: i, j
5766  !---------------------------------------------------------------------------
5767 
5768  !$acc data copy(var)
5769 
5770  is = ginfo(gid)%IS
5771  ie = ginfo(gid)%IE
5772  ihalo = ginfo(gid)%IHALO
5773  js = ginfo(gid)%JS
5774  je = ginfo(gid)%JE
5775  jhalo = ginfo(gid)%JHALO
5776 
5777  !$omp parallel
5778 
5779  !--- copy inner data to HALO(North)
5780  if( .NOT. prc_has_n ) then
5781  !$acc kernels async
5782  do j = je+1, je+jhalo
5783  !$omp do
5784  do i = is, ie
5785  var(i,j) = var(i,je)
5786  enddo
5787  !$omp end do nowait
5788  enddo
5789  !$acc end kernels
5790  endif
5791 
5792  !--- copy inner data to HALO(South)
5793  if( .NOT. prc_has_s ) then
5794  !$acc kernels async
5795  !$acc loop independent
5796  do j = js-jhalo, js-1
5797  !$omp do
5798  do i = is, ie
5799  var(i,j) = var(i,js)
5800  enddo
5801  !$omp end do nowait
5802  enddo
5803  !$acc end kernels
5804  endif
5805 
5806  if ( .not. prc_twod ) then
5807 
5808  if( .NOT. prc_has_e ) then
5809  !$omp do
5810  !$acc kernels async
5811  do j = js, je
5812  do i = ie+1, ie+ihalo
5813  var(i,j) = var(ie,j)
5814  enddo
5815  enddo
5816  !$acc end kernels
5817  !$omp end do nowait
5818  endif
5819 
5820  if( .NOT. prc_has_w ) then
5821  !$omp do
5822  !$acc kernels async
5823  do j = js, je
5824  !$acc loop independent
5825  do i = is-ihalo, is-1
5826  var(i,j) = var(is,j)
5827  enddo
5828  enddo
5829  !$acc end kernels
5830  !$omp end do nowait
5831  endif
5832 
5833  !--- copy inner data to HALO(NorthWest)
5834  if( .NOT. prc_has_n .AND. .NOT. prc_has_w ) then
5835  !$acc kernels async
5836  do j = je+1, je+jhalo
5837  !$acc loop independent
5838  do i = is-ihalo, is-1
5839  var(i,j) = var(is,je)
5840  enddo
5841  enddo
5842  !$acc end kernels
5843  elseif( .NOT. prc_has_n ) then
5844  !$acc kernels async
5845  do j = je+1, je+jhalo
5846  do i = is-ihalo, is-1
5847  var(i,j) = var(i,je)
5848  enddo
5849  enddo
5850  !$acc end kernels
5851  elseif( .NOT. prc_has_w ) then
5852  !$acc kernels async
5853  do j = je+1, je+jhalo
5854  !$acc loop independent
5855  do i = is-ihalo, is-1
5856  var(i,j) = var(is,j)
5857  enddo
5858  enddo
5859  !$acc end kernels
5860  endif
5861 
5862  !--- copy inner data to HALO(SouthWest)
5863  if( .NOT. prc_has_s .AND. .NOT. prc_has_w ) then
5864  !$acc kernels async
5865  !$acc loop independent
5866  do j = js-jhalo, js-1
5867  !$acc loop independent
5868  do i = is-ihalo, is-1
5869  var(i,j) = var(is,js)
5870  enddo
5871  enddo
5872  !$acc end kernels
5873  elseif( .NOT. prc_has_s ) then
5874  !$acc kernels async
5875  !$acc loop independent
5876  do j = js-jhalo, js-1
5877  do i = is-ihalo, is-1
5878  var(i,j) = var(i,js)
5879  enddo
5880  enddo
5881  !$acc end kernels
5882  elseif( .NOT. prc_has_w ) then
5883  !$acc kernels async
5884  do j = js-jhalo, js-1
5885  !$acc loop independent
5886  do i = is-ihalo, is-1
5887  var(i,j) = var(is,j)
5888  enddo
5889  enddo
5890  !$acc end kernels
5891  endif
5892 
5893  !--- copy inner data to HALO(NorthEast)
5894  if( .NOT. prc_has_n .AND. .NOT. prc_has_e ) then
5895  !$acc kernels async
5896  do j = je+1, je+jhalo
5897  do i = ie+1, ie+ihalo
5898  var(i,j) = var(ie,je)
5899  enddo
5900  enddo
5901  !$acc end kernels
5902  elseif( .NOT. prc_has_n ) then
5903  !$acc kernels async
5904  do j = je+1, je+jhalo
5905  do i = ie+1, ie+ihalo
5906  var(i,j) = var(i,je)
5907  enddo
5908  enddo
5909  !$acc end kernels
5910  elseif( .NOT. prc_has_e ) then
5911  !$acc kernels async
5912  do j = je+1, je+jhalo
5913  do i = ie+1, ie+ihalo
5914  var(i,j) = var(ie,j)
5915  enddo
5916  enddo
5917  !$acc end kernels
5918  endif
5919 
5920  !--- copy inner data to HALO(SouthEast)
5921  if( .NOT. prc_has_s .AND. .NOT. prc_has_e ) then
5922  !$acc kernels async
5923  do j = js-jhalo, js-1
5924  do i = ie+1, ie+ihalo
5925  var(i,j) = var(ie,js)
5926  enddo
5927  enddo
5928  !$acc end kernels
5929  elseif( .NOT. prc_has_s ) then
5930  !$acc kernels async
5931  !$acc loop independent
5932  do j = js-jhalo, js-1
5933  do i = ie+1, ie+ihalo
5934  var(i,j) = var(i,js)
5935  enddo
5936  enddo
5937  !$acc end kernels
5938  elseif( .NOT. prc_has_e ) then
5939  !$acc kernels async
5940  do j = js-jhalo, js-1
5941  do i = ie+1, ie+ihalo
5942  var(i,j) = var(ie,j)
5943  enddo
5944  enddo
5945  !$acc end kernels
5946  endif
5947 
5948  end if
5949 
5950  !$omp end parallel
5951 
5952  !$acc wait
5953 
5954  !$acc end data
5955 
5956  return
5957  end subroutine copy_boundary_2d
5958 
5959 end module scale_comm_cartesc
scale_comm_cartesc::comm_setup
subroutine, public comm_setup
Setup.
Definition: scale_comm_cartesC.F90:200
scale_comm_cartesc::comm_vars_init
subroutine, public comm_vars_init(varname, var, vid, gid)
Register variables.
Definition: scale_comm_cartesC.F90:742
scale_comm_cartesc::comm_datatype
integer, public comm_datatype
datatype of variable
Definition: scale_comm_cartesC.F90:105
scale_prc::prc_abort
subroutine, public prc_abort
Abort Process.
Definition: scale_prc.F90:350
scale_prc_cartesc::prc_n
integer, parameter, public prc_n
[node direction] north
Definition: scale_prc_cartesC.F90:34
scale_comm_cartesc::wait_2d_mpi
subroutine wait_2d_mpi(var, gid, vid)
Definition: scale_comm_cartesC.F90:4912
scale_tracer::qa
integer, public qa
Definition: scale_tracer.F90:35
scale_prc_cartesc::prc_sw
integer, parameter, public prc_sw
[node direction] southwest
Definition: scale_prc_cartesC.F90:39
scale_comm_cartesc::comm_bcast_1d_sp
subroutine comm_bcast_1d_sp(IA, var)
Broadcast data for whole process value in 1D field.
Definition: scale_comm_cartesC.F90:1391
scale_prc_cartesc::prc_next
integer, dimension(8), public prc_next
node ID of 8 neighbour process
Definition: scale_prc_cartesC.F90:46
scale_prc_cartesc::prc_has_s
logical, public prc_has_s
Definition: scale_prc_cartesC.F90:51
scale_precision
module PRECISION
Definition: scale_precision.F90:14
scale_comm_cartesc::comm_gather_2d
subroutine comm_gather_2d(IA, JA, send, recv)
Get data from whole process value in 2D field.
Definition: scale_comm_cartesC.F90:1265
scale_comm_cartesc::comm_horizontal_mean_3d
subroutine comm_horizontal_mean_3d(KA, IA, IS, IE, JA, JS, JE, var, varmean)
calculate horizontal mean (global total with communication) 3D
Definition: scale_comm_cartesC.F90:1181
scale_prc::prc_local_comm_world
integer, public prc_local_comm_world
local communicator
Definition: scale_prc.F90:89
scale_comm_cartesc::vars_3d_mpi_onesided
subroutine vars_3d_mpi_onesided(var, gid, vid)
Definition: scale_comm_cartesC.F90:2652
scale_comm_cartesc::wait_3d_mpi_pc
subroutine wait_3d_mpi_pc(var, gid, vid)
Definition: scale_comm_cartesC.F90:5002
scale_comm_cartesc::comm_vars_3d
subroutine comm_vars_3d(var, vid, gid)
Definition: scale_comm_cartesC.F90:876
scale_comm_cartesc::vars8_3d_mpi_onesided
subroutine vars8_3d_mpi_onesided(var, gid, vid)
Definition: scale_comm_cartesC.F90:3314
scale_comm_cartesc::comm_bcast_scr_sp
subroutine comm_bcast_scr_sp(var)
Broadcast data for whole process value in scalar field.
Definition: scale_comm_cartesC.F90:1336
scale_prc_cartesc::prc_se
integer, parameter, public prc_se
[node direction] southeast
Definition: scale_prc_cartesC.F90:40
scale_prc_cartesc::prc_has_n
logical, public prc_has_n
Definition: scale_prc_cartesC.F90:49
scale_comm_cartesc::comm_bcast_scr_dp
subroutine comm_bcast_scr_dp(var)
Definition: scale_comm_cartesC.F90:1362
scale_prc_cartesc::prc_has_e
logical, public prc_has_e
Definition: scale_prc_cartesC.F90:50
scale_prc
module PROCESS
Definition: scale_prc.F90:11
scale_comm_cartesc::comm_bcast_1d_dp
subroutine comm_bcast_1d_dp(IA, var)
Definition: scale_comm_cartesC.F90:1421
scale_precision::rp
integer, parameter, public rp
Definition: scale_precision.F90:41
scale_io
module STDIO
Definition: scale_io.F90:10
scale_prc::prc_masterrank
integer, parameter, public prc_masterrank
master process in each communicator
Definition: scale_prc.F90:67
scale_const
module CONSTANT
Definition: scale_const.F90:11
scale_comm_cartesc::copy_boundary_2d
subroutine copy_boundary_2d(var, gid)
Definition: scale_comm_cartesC.F90:5755
scale_comm_cartesc::comm_bcast_4d_dp
subroutine comm_bcast_4d_dp(KA, IA, JA, NT, var)
Definition: scale_comm_cartesC.F90:1616
scale_comm_cartesc::comm_regist
subroutine, public comm_regist(KA, IA, JA, IHALO, JHALO, gid)
Regist grid.
Definition: scale_comm_cartesC.F90:446
scale_comm_cartesc::comm_gather_3d
subroutine comm_gather_3d(KA, IA, JA, send, recv)
Get data from whole process value in 3D field.
Definition: scale_comm_cartesC.F90:1302
scale_prc_cartesc::prc_w
integer, parameter, public prc_w
[node direction] west
Definition: scale_prc_cartesC.F90:33
scale_comm_cartesc::vars_3d_mpi
subroutine vars_3d_mpi(var, gid, vid)
Definition: scale_comm_cartesC.F90:2497
scale_prc_cartesc
module process / cartesC
Definition: scale_prc_cartesC.F90:11
scale_comm_cartesc::comm_finalize
subroutine, public comm_finalize
Finalize.
Definition: scale_comm_cartesC.F90:626
scale_comm_cartesc::comm_horizontal_mean_2d
subroutine comm_horizontal_mean_2d(IA, IS, IE, JA, JS, JE, var, varmean)
calculate horizontal mean (global total with communication) 2D
Definition: scale_comm_cartesC.F90:1119
scale_comm_cartesc::comm_bcast_character
subroutine comm_bcast_character(var)
Broadcast data for whole process value in character.
Definition: scale_comm_cartesC.F90:1808
scale_comm_cartesc::vars8_3d_mpi
subroutine vars8_3d_mpi(var, gid, vid)
Definition: scale_comm_cartesC.F90:2756
scale_comm_cartesc::comm_vars_2d
subroutine comm_vars_2d(var, vid, gid)
Definition: scale_comm_cartesC.F90:1005
scale_prof
module profiler
Definition: scale_prof.F90:11
scale_comm_cartesc::comm_bcast_int_2d
subroutine comm_bcast_int_2d(IA, JA, var)
Broadcast data for whole process value in 2D field (integer)
Definition: scale_comm_cartesC.F90:1714
scale_comm_cartesc::comm_wait_3d
subroutine comm_wait_3d(var, vid, FILL_BND, gid)
Definition: scale_comm_cartesC.F90:954
scale_comm_cartesc::vars8_2d_mpi_onesided
subroutine vars8_2d_mpi_onesided(var, gid, vid)
Definition: scale_comm_cartesC.F90:4478
scale_comm_cartesc::comm_bcast_int_1d
subroutine comm_bcast_int_1d(IA, var)
Broadcast data for whole process value in 1D field (integer)
Definition: scale_comm_cartesC.F90:1684
scale_tracer
module TRACER
Definition: scale_tracer.F90:12
scale_comm_cartesc::comm_world
integer, public comm_world
communication world ID
Definition: scale_comm_cartesC.F90:106
scale_prc_cartesc::prc_s
integer, parameter, public prc_s
[node direction] south
Definition: scale_prc_cartesC.F90:36
scale_comm_cartesc::wait_3d_mpi_onesided
subroutine wait_3d_mpi_onesided(var, gid, vid)
Definition: scale_comm_cartesC.F90:4862
scale_comm_cartesc::comm_bcast_3d_sp
subroutine comm_bcast_3d_sp(KA, IA, JA, var)
Broadcast data for whole process value in 3D field.
Definition: scale_comm_cartesC.F90:1517
scale_comm_cartesc::comm_vars8_2d
subroutine comm_vars8_2d(var, vid, gid)
Definition: scale_comm_cartesC.F90:1038
scale_comm_cartesc
module COMMUNICATION
Definition: scale_comm_cartesC.F90:11
scale_comm_cartesc::comm_bcast_2d_dp
subroutine comm_bcast_2d_dp(IA, JA, var)
Definition: scale_comm_cartesC.F90:1484
scale_prc_cartesc::prc_nw
integer, parameter, public prc_nw
[node direction] northwest
Definition: scale_prc_cartesC.F90:37
scale_comm_cartesc::comm_vars8_3d
subroutine comm_vars8_3d(var, vid, gid)
Definition: scale_comm_cartesC.F90:915
scale_comm_cartesc::comm_bcast_2d_sp
subroutine comm_bcast_2d_sp(IA, JA, var)
Broadcast data for whole process value in 2D field.
Definition: scale_comm_cartesC.F90:1454
scale_comm_cartesc::comm_bcast_4d_sp
subroutine comm_bcast_4d_sp(KA, IA, JA, NT, var)
Broadcast data for whole process value in 4D field.
Definition: scale_comm_cartesC.F90:1580
scale_comm_cartesc::vars_2d_mpi
subroutine vars_2d_mpi(var, gid, vid)
Definition: scale_comm_cartesC.F90:3609
scale_prc_cartesc::prc_e
integer, parameter, public prc_e
[node direction] east
Definition: scale_prc_cartesC.F90:35
scale_comm_cartesc::vars_2d_mpi_onesided
subroutine vars_2d_mpi_onesided(var, gid, vid)
Definition: scale_comm_cartesC.F90:3761
scale_comm_cartesc::packwe_3d
subroutine packwe_3d(KA, IA, IS, IE, JA, JS, JE, IHALO, var, gid, vid)
Definition: scale_comm_cartesC.F90:5054
scale_comm_cartesc::wait_2d_mpi_onesided
subroutine wait_2d_mpi_onesided(var, gid, vid)
Definition: scale_comm_cartesC.F90:4954
scale_comm_cartesc::vars8_init_mpi_pc
subroutine vars8_init_mpi_pc(var, gid, vid, seqid)
Definition: scale_comm_cartesC.F90:1975
scale_comm_cartesc::vars_init_mpi_pc
subroutine vars_init_mpi_pc(var, gid, vid, seqid)
Definition: scale_comm_cartesC.F90:1838
scale_comm_cartesc::wait_3d_mpi
subroutine wait_3d_mpi(var, gid, vid)
Definition: scale_comm_cartesC.F90:4819
scale_comm_cartesc::comm_vars8_init
subroutine, public comm_vars8_init(varname, var, vid, gid)
Register variables.
Definition: scale_comm_cartesC.F90:811
scale_const::const_undef
real(rp), public const_undef
Definition: scale_const.F90:43
scale_prc_cartesc::prc_ne
integer, parameter, public prc_ne
[node direction] northeast
Definition: scale_prc_cartesC.F90:38
scale_comm_cartesc::comm_bcast_logical_scr
subroutine comm_bcast_logical_scr(var)
Broadcast data for whole process value in scalar (logical)
Definition: scale_comm_cartesC.F90:1747
scale_prc_cartesc::prc_has_w
logical, public prc_has_w
Definition: scale_prc_cartesC.F90:48
scale_comm_cartesc::comm_bcast_3d_dp
subroutine comm_bcast_3d_dp(KA, IA, JA, var)
Definition: scale_comm_cartesC.F90:1547
scale_io::io_fid_conf
integer, public io_fid_conf
Config file ID.
Definition: scale_io.F90:57
scale_prc_cartesc::prc_twod
logical, public prc_twod
2D experiment
Definition: scale_prc_cartesC.F90:56
scale_comm_cartesc::comm_bcast_logical_1d
subroutine comm_bcast_logical_1d(IA, var)
Broadcast data for whole process value in 1D (logical)
Definition: scale_comm_cartesC.F90:1776
scale_comm_cartesc::comm_wait_2d
subroutine comm_wait_2d(var, vid, FILL_BND, gid)
Definition: scale_comm_cartesC.F90:1071
scale_comm_cartesc::vars_3d_mpi_pc
subroutine vars_3d_mpi_pc(var, gid, vid)
Definition: scale_comm_cartesC.F90:4767
scale_comm_cartesc::comm_bcast_int_scr
subroutine comm_bcast_int_scr(var)
Broadcast data for whole process value in scalar (integer)
Definition: scale_comm_cartesC.F90:1655
scale_comm_cartesc::vars8_2d_mpi
subroutine vars8_2d_mpi(var, gid, vid)
Definition: scale_comm_cartesC.F90:3863
Generated by   doxygen 1.8.17