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