SCALE-RM
Data Types | Functions/Subroutines | Variables
scale_comm_cartesc Module Reference

module COMMUNICATION More...

Functions/Subroutines

subroutine, public comm_setup
 Setup. More...
 
subroutine, public comm_regist (KA, IA, JA, IHALO, JHALO, gid)
 Regist grid. More...
 
subroutine, public comm_finalize
 Finalize. More...
 
subroutine, public comm_vars_init (varname, var, vid, gid)
 Register variables. More...
 
subroutine, public comm_vars8_init (varname, var, vid, gid)
 Register variables. More...
 
subroutine comm_vars_3d (var, vid, gid)
 
subroutine comm_vars8_3d (var, vid, gid)
 
subroutine comm_wait_3d (var, vid, FILL_BND, gid)
 
subroutine comm_vars_2d (var, vid, gid)
 
subroutine comm_vars8_2d (var, vid, gid)
 
subroutine comm_wait_2d (var, vid, FILL_BND, gid)
 
subroutine comm_horizontal_mean_2d (IA, IS, IE, JA, JS, JE, var, varmean)
 calculate horizontal mean (global total with communication) 2D More...
 
subroutine comm_horizontal_mean_3d (KA, IA, IS, IE, JA, JS, JE, var, varmean)
 calculate horizontal mean (global total with communication) 3D More...
 
subroutine comm_gather_2d (IA, JA, send, recv)
 Get data from whole process value in 2D field. More...
 
subroutine comm_gather_3d (KA, IA, JA, send, recv)
 Get data from whole process value in 3D field. More...
 
subroutine comm_bcast_scr_sp (var)
 Broadcast data for whole process value in scalar field. More...
 
subroutine comm_bcast_scr_dp (var)
 
subroutine comm_bcast_1d_sp (IA, var)
 Broadcast data for whole process value in 1D field. More...
 
subroutine comm_bcast_1d_dp (IA, var)
 
subroutine comm_bcast_2d_sp (IA, JA, var)
 Broadcast data for whole process value in 2D field. More...
 
subroutine comm_bcast_2d_dp (IA, JA, var)
 
subroutine comm_bcast_3d_sp (KA, IA, JA, var)
 Broadcast data for whole process value in 3D field. More...
 
subroutine comm_bcast_3d_dp (KA, IA, JA, var)
 
subroutine comm_bcast_4d_sp (KA, IA, JA, NT, var)
 Broadcast data for whole process value in 4D field. More...
 
subroutine comm_bcast_4d_dp (KA, IA, JA, NT, var)
 
subroutine comm_bcast_int_scr (var)
 Broadcast data for whole process value in scalar (integer) More...
 
subroutine comm_bcast_int_1d (IA, var)
 Broadcast data for whole process value in 1D field (integer) More...
 
subroutine comm_bcast_int_2d (IA, JA, var)
 Broadcast data for whole process value in 2D field (integer) More...
 
subroutine comm_bcast_logical_scr (var)
 Broadcast data for whole process value in scalar (logical) More...
 
subroutine comm_bcast_logical_1d (IA, var)
 Broadcast data for whole process value in 1D (logical) More...
 
subroutine comm_bcast_character (var)
 Broadcast data for whole process value in character. More...
 
subroutine vars_init_mpi_pc (var, gid, vid, seqid)
 
subroutine vars8_init_mpi_pc (var, gid, vid, seqid)
 
subroutine vars_3d_mpi (var, gid, vid)
 
subroutine vars_3d_mpi_onesided (var, gid, vid)
 
subroutine vars8_3d_mpi (var, gid, vid)
 
subroutine vars8_3d_mpi_onesided (var, gid, vid)
 
subroutine vars_2d_mpi (var, gid, vid)
 
subroutine vars_2d_mpi_onesided (var, gid, vid)
 
subroutine vars8_2d_mpi (var, gid, vid)
 
subroutine vars8_2d_mpi_onesided (var, gid, vid)
 
subroutine vars_3d_mpi_pc (var, gid, vid)
 
subroutine wait_3d_mpi (var, gid, vid)
 
subroutine wait_3d_mpi_onesided (var, gid, vid)
 
subroutine wait_2d_mpi (var, gid, vid)
 
subroutine wait_2d_mpi_onesided (var, gid, vid)
 
subroutine wait_3d_mpi_pc (var, gid, vid)
 
subroutine packwe_3d (KA, IA, IS, IE, JA, JS, JE, IHALO, var, gid, vid)
 
subroutine copy_boundary_2d (var, gid)
 

Variables

integer, public comm_datatype
 datatype of variable More...
 
integer, public comm_world
 communication world ID More...
 

Detailed Description

module COMMUNICATION

Description
MPI Communication module for Cartesian C-grid
Author
Team SCALE
NAMELIST
  • PARAM_COMM_CARTESC
    nametypedefault valuecomment
    COMM_VSIZE_MAX integer # limit of communication variables at once
    COMM_VSIZE_MAX_PC integer # limit of total communication variables for MPI PC
    COMM_USE_MPI_PC logical .true. MPI persistent communication
    COMM_USE_MPI_ONESIDED logical .false. MPI one-sided communication

History Output
No history output

Function/Subroutine Documentation

◆ comm_setup()

subroutine, public scale_comm_cartesc::comm_setup

Setup.

Definition at line 199 of file scale_comm_cartesC.F90.

200  use scale_prc, only: &
201  prc_abort, &
202  prc_local_comm_world
203  use scale_prc_cartesc, only: &
204  prc_twod
205  implicit none
206 
207  namelist / param_comm_cartesc / &
208  comm_vsize_max, &
209  comm_vsize_max_pc, &
210  comm_use_mpi_pc, &
211  comm_use_mpi_onesided
212 
213  integer :: ranks(8)
214 #ifdef NO_MPI08
215  integer :: group
216 #else
217  type(MPI_Group) :: group
218 #endif
219 
220  integer :: n, m
221  integer :: ierr
222  !---------------------------------------------------------------------------
223 
224  if ( initialized ) return
225 
226  log_newline
227  log_info("COMM_setup",*) 'Setup'
228 
229  comm_vsize_max = max( 10 + qa*2, 25 )
230  comm_vsize_max_pc = 50 + qa*2
231 
232 #ifdef _OPENACC
233  comm_use_mpi_onesided = .false.
234 #endif
235 
236  !--- read namelist
237  rewind(io_fid_conf)
238  read(io_fid_conf,nml=param_comm_cartesc,iostat=ierr)
239  if( ierr < 0 ) then !--- missing
240  log_info("COMM_setup",*) 'Not found namelist. Default used.'
241  elseif( ierr > 0 ) then !--- fatal error
242  log_error("COMM_setup",*) 'Not appropriate names in namelist PARAM_COMM_CARTESC. Check!'
243  call prc_abort
244  endif
245  log_nml(param_comm_cartesc)
246 
247  if ( prc_has_n .AND. prc_has_s .AND. prc_has_w .AND. prc_has_e ) then
248  comm_isallperiodic = .true.
249  else
250  comm_isallperiodic = .false.
251  endif
252 
253  comm_world = prc_local_comm_world
254 
255  if ( rp == kind(0.d0) ) then
256  comm_datatype_t = mpi_double_precision
257  elseif( rp == kind(0.0) ) then
258  comm_datatype_t = mpi_real
259  else
260  log_error("COMM_setup",*) 'precision is not supportd'
261  call prc_abort
262  endif
263 
264 #ifdef NO_MPI08
265  comm_world_t = comm_world
266  comm_datatype = comm_datatype_t
267 #else
268  comm_world_t%MPI_VAL = comm_world
269  comm_datatype = comm_datatype_t%MPI_VAL
270 #endif
271 
272  comm_gid = 0
273 
274 #ifdef _OPENACC
275  if ( comm_use_mpi_onesided ) then
276  log_warn("COMM_setup",*) "Open MPI does not support one-sided APIs with CUDA-aware UCX"
277  end if
278 #endif
279 
280  if ( comm_use_mpi_onesided ) then
281 
282  comm_use_mpi_pc = .false.
283 
284  call mpi_comm_group( comm_world_t, group, ierr )
285 
286  n = 0
287  if ( prc_has_s ) then
288  n = 1
289  ranks(n) = prc_next(prc_s)
290  end if
291  if ( prc_has_n ) then
292  do m = 1, n
293  if ( ranks(m) == prc_next(prc_n) ) exit
294  end do
295  if ( m == n + 1 ) then
296  n = n + 1
297  ranks(n) = prc_next(prc_n)
298  end if
299  end if
300  if ( prc_has_n .and. prc_has_w ) then
301  do m = 1, n
302  if ( ranks(m) == prc_next(prc_nw) ) exit
303  end do
304  if ( m == n + 1 ) then
305  n = n + 1
306  ranks(n) = prc_next(prc_nw)
307  end if
308  else if ( prc_has_n ) then
309  do m = 1, n
310  if ( ranks(m) == prc_next(prc_n) ) exit
311  end do
312  if ( m == n + 1 ) then
313  n = n + 1
314  ranks(n) = prc_next(prc_n)
315  end if
316  else if ( prc_has_w ) then
317  do m = 1, n
318  if ( ranks(m) == prc_next(prc_w) ) exit
319  end do
320  if ( m == n + 1 ) then
321  n = n + 1
322  ranks(n) = prc_next(prc_w)
323  end if
324  end if
325  if ( prc_has_n .and. prc_has_e ) then
326  do m = 1, n
327  if ( ranks(m) == prc_next(prc_ne) ) exit
328  end do
329  if ( m == n + 1 ) then
330  n = n + 1
331  ranks(n) = prc_next(prc_ne)
332  end if
333  else if ( prc_has_n ) then
334  do m = 1, n
335  if ( ranks(m) == prc_next(prc_n) ) exit
336  end do
337  if ( m == n + 1 ) then
338  n = n + 1
339  ranks(n) = prc_next(prc_n)
340  end if
341  else if ( prc_has_e ) then
342  do m = 1, n
343  if ( ranks(m) == prc_next(prc_e) ) exit
344  end do
345  if ( m == n + 1 ) then
346  n = n + 1
347  ranks(n) = prc_next(prc_e)
348  end if
349  end if
350  if ( prc_has_s .and. prc_has_w ) then
351  do m = 1, n
352  if ( ranks(m) == prc_next(prc_sw) ) exit
353  end do
354  if ( m == n + 1 ) then
355  n = n + 1
356  ranks(n) = prc_next(prc_sw)
357  end if
358  else if ( prc_has_s ) then
359  do m = 1, n
360  if ( ranks(m) == prc_next(prc_s) ) exit
361  end do
362  if ( m == n + 1 ) then
363  n = n + 1
364  ranks(n) = prc_next(prc_s)
365  end if
366  else if ( prc_has_w ) then
367  do m = 1, n
368  if ( ranks(m) == prc_next(prc_w) ) exit
369  end do
370  if ( m == n + 1 ) then
371  n = n + 1
372  ranks(n) = prc_next(prc_w)
373  end if
374  end if
375  if ( prc_has_s .and. prc_has_e ) then
376  do m = 1, n
377  if ( ranks(m) == prc_next(prc_se) ) exit
378  end do
379  if ( m == n + 1 ) then
380  n = n + 1
381  ranks(n) = prc_next(prc_se)
382  end if
383  else if ( prc_has_s ) then
384  do m = 1, n
385  if ( ranks(m) == prc_next(prc_s) ) exit
386  end do
387  if ( m == n + 1 ) then
388  n = n + 1
389  ranks(n) = prc_next(prc_s)
390  end if
391  else if ( prc_has_e ) then
392  do m = 1, n
393  if ( ranks(m) == prc_next(prc_e) ) exit
394  end do
395  if ( m == n + 1 ) then
396  n = n + 1
397  ranks(n) = prc_next(prc_e)
398  end if
399  end if
400  if ( n > 0 ) then
401  call mpi_group_incl( group, n, ranks, group_packns, ierr )
402  group_packns_created = .true.
403  else
404  group_packns_created = .false.
405  end if
406 
407  n = 0
408  if ( .not. prc_twod ) then
409  if ( prc_has_w ) then
410  n = 1
411  ranks(n) = prc_next(prc_w)
412  end if
413  if ( prc_has_e ) then
414  if ( n == 0 .or. ranks(1) .ne. prc_next(prc_e) ) then
415  n = n + 1
416  ranks(n) = prc_next(prc_e)
417  end if
418  end if
419  end if
420  if ( n > 0 ) then
421  call mpi_group_incl( group, n, ranks, group_packwe, ierr )
422  group_packwe_created = .true.
423  else
424  group_packwe_created = .false.
425  end if
426 
427  call mpi_group_free( group, ierr )
428  end if
429 
430  log_newline
431  log_info("COMM_setup",*) 'Communication information'
432  log_info_cont(*) 'Maximum number of vars for one communication: ', comm_vsize_max
433  log_info_cont(*) 'All side is periodic? : ', comm_isallperiodic
434 
435 
436  initialized = .true.
437 
438  return
scale_prc_cartesc
module process / cartesC
Definition: scale_prc_cartesC.F90:11
scale_prc_cartesc::prc_twod
logical, public prc_twod
2D experiment
Definition: scale_prc_cartesC.F90:56
scale_prc
module PROCESS
Definition: scale_prc.F90:11
scale_prc::prc_local_comm_world
integer, public prc_local_comm_world
local communicator
Definition: scale_prc.F90:89
scale_prc::prc_abort
subroutine, public prc_abort
Abort Process.
Definition: scale_prc.F90:350

References comm_datatype, comm_world, scale_io::io_fid_conf, scale_prc::prc_abort(), scale_prc::prc_local_comm_world, scale_prc_cartesc::prc_twod, scale_tracer::qa, and scale_precision::rp.

Referenced by mod_rm_driver::rm_driver(), mod_rm_prep::rm_prep(), and scale_statistics::statistics_setup().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ comm_regist()

subroutine, public scale_comm_cartesc::comm_regist ( integer, intent(in)  KA,
integer, intent(in)  IA,
integer, intent(in)  JA,
integer, intent(in)  IHALO,
integer, intent(in)  JHALO,
integer, intent(out)  gid 
)

Regist grid.

Definition at line 443 of file scale_comm_cartesC.F90.

446  use scale_prc, only: &
447  prc_abort
448  implicit none
449 
450  integer, intent(in) :: KA, IA, JA, IHALO, JHALO
451  integer, intent(out) :: gid
452 
453  integer :: IMAX, JMAX
454  integer :: nreq_NS, nreq_WE, nreq_4C
455 
456 #ifdef NO_MPI08
457  integer :: win_info
458 #else
459  type(MPI_Info) :: win_info
460 #endif
461 
462  integer(kind=MPI_ADDRESS_KIND) :: size
463 
464  integer :: ierr
465  integer :: n
466 
467  if ( .not. initialized ) then
468  log_error("COMM_regist",*) 'COMM_setup must be called before calling COMM_regist'
469  call prc_abort
470  end if
471 
472  comm_gid = comm_gid + 1
473  if ( comm_gid > comm_gid_max ) then
474  log_error("COMM_regist",*) 'number of registed grid size exceeds the limit'
475  call prc_abort
476  end if
477  gid = comm_gid
478 
479  if ( ia < ihalo * 3 ) then
480  log_error("COMM_regist",*) 'IA must be >= IHALO * 3'
481  call prc_abort
482  end if
483  if ( ja < jhalo * 3 ) then
484  log_error("COMM_regist",*) 'JA must be >= JHALO * 3'
485  call prc_abort
486  end if
487 
488  imax = ia - ihalo * 2
489  jmax = ja - jhalo * 2
490 
491  ginfo(gid)%KA = ka
492  ginfo(gid)%IA = ia
493  ginfo(gid)%IS = ihalo + 1
494  ginfo(gid)%IE = ia - ihalo
495  ginfo(gid)%IHALO = ihalo
496  ginfo(gid)%JA = ja
497  ginfo(gid)%JS = jhalo + 1
498  ginfo(gid)%JE = ja - jhalo
499  ginfo(gid)%JHALO = jhalo
500 
501  nreq_ns = 2 * jhalo !--- send x JHALO, recv x JHALO
502  nreq_we = 2 !--- send x 1 , recv x 1
503  nreq_4c = 2 * jhalo !--- send x JHALO, recv x JHALO
504 
505  if ( comm_use_mpi_pc ) then
506  ginfo(gid)%nreq_MAX = 2 * nreq_ns + 2 * nreq_we + 4 * nreq_4c + 1
507  else
508  ginfo(gid)%nreq_MAX = 2 * nreq_ns + 2 * nreq_we + 4 * nreq_4c
509  end if
510 
511  ginfo(gid)%size2D_NS4 = ia * jhalo
512  ginfo(gid)%size2D_NS8 = imax
513  ginfo(gid)%size2D_WE = jmax * ihalo
514  ginfo(gid)%size2D_4C = ihalo
515 
516  allocate( ginfo(gid)%sendpack_P2WE(ginfo(gid)%size2D_WE * ka, 2, comm_vsize_max) )
517  !$acc enter data create(ginfo(gid)%sendpack_P2WE)
518 
519 #ifdef DEBUG
520  allocate( ginfo(gid)%use_packbuf(comm_vsize_max) )
521  ginfo(gid)%use_packbuf(:) = .false.
522 #endif
523 
524 #ifdef _OPENACC
525  allocate( ginfo(gid)%device_alloc(comm_vsize_max+comm_vsize_max_pc) )
526  allocate( ginfo(gid)%device_ptr(comm_vsize_max+1:comm_vsize_max_pc) )
527  ginfo(gid)%device_alloc(:) = .false.
528 #endif
529 
530  if ( comm_use_mpi_onesided ) then
531 
532  allocate( ginfo(gid)%recvbuf_WE(comm_vsize_max) )
533  allocate( ginfo(gid)%recvbuf_NS(comm_vsize_max) )
534 
535  allocate( ginfo(gid)%win_packWE(comm_vsize_max) )
536  allocate( ginfo(gid)%win_packNS(comm_vsize_max) )
537 
538  call mpi_info_create(win_info, ierr)
539  call mpi_info_set(win_info, "no_locks", "true", ierr)
540  call mpi_info_set(win_info, "same_size", "true", ierr)
541  call mpi_info_set(win_info, "same_disp_unit", "true", ierr)
542 
543  do n = 1, comm_vsize_max
544  size = ginfo(gid)%size2D_WE * ka * 2 * rp
545 #ifdef _OPENACC
546  block
547  real(RP), pointer :: pack(:)
548  call mpi_alloc_mem(size, mpi_info_null, ginfo(gid)%recvbuf_WE(n), ierr)
549  call c_f_pointer(ginfo(gid)%recvbuf_WE(n), pack, (/ size/rp /))
550  !$acc enter data create(pack)
551  !$acc host_data use_device(pack)
552  call mpi_win_create(pack, size, ginfo(gid)%size2D_WE*ka*rp, &
553  win_info, comm_world_t, &
554  ginfo(gid)%win_packWE(n), ierr)
555  !$acc end host_data
556  end block
557 #else
558  call mpi_win_allocate(size, ginfo(gid)%size2D_WE*ka*rp, &
559  win_info, comm_world_t, &
560  ginfo(gid)%recvbuf_WE(n), ginfo(gid)%win_packWE(n), ierr)
561 #endif
562  size = ginfo(gid)%size2D_NS4 * ka * 2 * rp
563 #ifdef _OPENACC
564  block
565  real(RP), pointer :: pack(:)
566  call mpi_alloc_mem(size, mpi_info_null, ginfo(gid)%recvbuf_NS(n), ierr)
567  call c_f_pointer(ginfo(gid)%recvbuf_NS(n), pack, (/ size/rp /))
568  !$acc enter data create(pack)
569  !$acc host_data use_device(pack)
570  call mpi_win_create(pack, size, rp, &
571  win_info, comm_world_t, &
572  ginfo(gid)%win_packNS(n), ierr)
573  !$acc end host_data
574  end block
575 #else
576  call mpi_win_allocate(size, rp, &
577  win_info, comm_world_t, &
578  ginfo(gid)%recvbuf_NS(n), ginfo(gid)%win_packNS(n), ierr)
579 #endif
580  end do
581 
582  call mpi_info_free(win_info, ierr)
583 
584  do n = 1, comm_vsize_max
585  call mpi_win_post( group_packwe, mpi_mode_nostore, ginfo(gid)%win_packWE(n), ierr )
586  call mpi_win_post( group_packns, mpi_mode_nostore, ginfo(gid)%win_packNS(n), ierr )
587  end do
588 
589  ginfo(gid)%vars_num = 0
590  allocate( ginfo(gid)%packid(comm_vsize_max_pc) )
591 
592  else
593 
594  allocate( ginfo(gid)%recvpack_WE2P(ginfo(gid)%size2D_WE * ka, 2, comm_vsize_max) )
595  !$acc enter data create(ginfo(gid)%recvpack_WE2P)
596 
597  allocate( ginfo(gid)%req_cnt ( comm_vsize_max) )
598  allocate( ginfo(gid)%req_list(ginfo(gid)%nreq_MAX, comm_vsize_max) )
599  ginfo(gid)%req_cnt (:) = -1
600  ginfo(gid)%req_list(:,:) = mpi_request_null
601 
602  if ( comm_use_mpi_pc ) then
603  ginfo(gid)%vars_num = 0
604  allocate( ginfo(gid)%packid(comm_vsize_max_pc) )
605  allocate( ginfo(gid)%preq_cnt ( comm_vsize_max_pc) )
606  allocate( ginfo(gid)%preq_list(ginfo(gid)%nreq_MAX+1,comm_vsize_max_pc) )
607  ginfo(gid)%preq_cnt (:) = -1
608  ginfo(gid)%preq_list(:,:) = mpi_request_null
609  end if
610 
611  end if
612 
613 
614  log_newline
615  log_info("COMM_regist",*) 'Register grid: id=', gid
616  log_info_cont(*) 'Data size of var (3D,including halo) [byte] : ', rp*ka*ia*ja
617  log_info_cont(*) 'Data size of halo [byte] : ', rp*ka*(2*ia*jhalo+2*jmax*ihalo)
618  log_info_cont(*) 'Ratio of halo against the whole 3D grid : ', real(2*ia*jhalo+2*jmax*ihalo) / real(ia*ja)
619 
620  return

References scale_prc::prc_abort(), and scale_precision::rp.

Referenced by mod_rm_driver::rm_driver(), and mod_rm_prep::rm_prep().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ comm_finalize()

subroutine, public scale_comm_cartesc::comm_finalize

Finalize.

Definition at line 625 of file scale_comm_cartesC.F90.

626  implicit none
627 
628  integer :: gid
629  integer :: i, j, ierr
630  !---------------------------------------------------------------------------
631 
632  do gid = 1, comm_gid
633 
634  if ( comm_use_mpi_onesided ) then
635 
636  do i = 1, comm_vsize_max
637  call mpi_win_start( group_packwe, 0, ginfo(gid)%win_packWE(i), ierr )
638  call mpi_win_start( group_packns, 0, ginfo(gid)%win_packNS(i), ierr )
639  end do
640 
641  do i = 1, comm_vsize_max
642  call mpi_win_complete( ginfo(gid)%win_packWE(i), ierr )
643  call mpi_win_complete( ginfo(gid)%win_packNS(i), ierr )
644  end do
645 
646  do i = 1, comm_vsize_max
647  call mpi_win_wait( ginfo(gid)%win_packWE(i), ierr )
648  call mpi_win_wait( ginfo(gid)%win_packNS(i), ierr )
649  end do
650 
651  do i = 1, comm_vsize_max
652  call mpi_win_free(ginfo(gid)%win_packWE(i), ierr)
653  call mpi_win_free(ginfo(gid)%win_packNS(i), ierr)
654 #ifdef _OPENACC
655  block
656  real(RP), pointer :: pack(:)
657  integer :: KA
658  ka = ginfo(gid)%KA
659  call c_f_pointer( ginfo(gid)%recvbuf_WE(i), pack, (/ginfo(gid)%size2D_WE*ka*2/) )
660  !$acc exit data delete(pack)
661  call c_f_pointer( ginfo(gid)%recvbuf_NS(i), pack, (/ginfo(gid)%size2D_NS4*ka*2/) )
662  !$acc exit data delete(pack)
663  end block
664  call mpi_free_mem(ginfo(gid)%recvbuf_WE(i), ierr)
665  call mpi_free_mem(ginfo(gid)%recvbuf_NS(i), ierr)
666 #endif
667  end do
668 
669  deallocate( ginfo(gid)%packid )
670  ginfo(gid)%vars_num = 0
671 
672  deallocate( ginfo(gid)%win_packWE )
673  deallocate( ginfo(gid)%win_packNS )
674 
675  deallocate( ginfo(gid)%recvbuf_WE )
676  deallocate( ginfo(gid)%recvbuf_NS )
677 
678  else
679 
680  if ( comm_use_mpi_pc ) then
681 
682  do j = 1, comm_vsize_max_pc
683  do i = 1, ginfo(gid)%nreq_MAX+1
684  if (ginfo(gid)%preq_list(i,j) .NE. mpi_request_null) &
685  call mpi_request_free(ginfo(gid)%preq_list(i,j), ierr)
686  enddo
687 #ifdef _OPENACC
688  if ( ginfo(gid)%device_alloc(j+comm_vsize_max) ) then
689  !$acc exit data delete(ginfo(gid)%device_ptr(j+COMM_vsize_max)%ptr)
690  end if
691 #endif
692  enddo
693  deallocate( ginfo(gid)%preq_cnt )
694  deallocate( ginfo(gid)%preq_list )
695  deallocate( ginfo(gid)%packid )
696  ginfo(gid)%vars_num = 0
697 #ifdef _OPENACC
698  deallocate( ginfo(gid)%device_ptr )
699  deallocate( ginfo(gid)%device_alloc )
700 #endif
701 
702  end if
703 
704  deallocate( ginfo(gid)%req_cnt )
705  deallocate( ginfo(gid)%req_list )
706 
707  !$acc exit data delete(ginfo(gid)%recvpack_WE2P)
708  deallocate( ginfo(gid)%recvpack_WE2P )
709 
710  end if
711 
712  !$acc exit data delete(ginfo(gid)%sendpack_P2WE)
713  deallocate( ginfo(gid)%sendpack_P2WE )
714 #ifdef DEBUG
715  deallocate( ginfo(gid)%use_packbuf )
716 #endif
717 
718  end do
719 
720  if ( comm_use_mpi_onesided ) then
721  if ( group_packwe_created ) then
722  call mpi_group_free(group_packwe, ierr)
723  group_packwe_created = .false.
724  end if
725  if ( group_packns_created ) then
726  call mpi_group_free(group_packns, ierr)
727  group_packns_created = .false.
728  end if
729  end if
730 
731 
732  comm_gid = 0
733 
734  initialized = .false.
735 
736  return

Referenced by mod_rm_driver::rm_driver(), and mod_rm_prep::rm_prep().

Here is the caller graph for this function:

◆ comm_vars_init()

subroutine, public scale_comm_cartesc::comm_vars_init ( character(len=*), intent(in)  varname,
real(rp), dimension(:,:,:), intent(inout), target  var,
integer, intent(inout)  vid,
integer, intent(in), optional  gid 
)

Register variables.

Parameters
[in]varnamevariable name
[in,out]varvariable array for register
[in,out]vidvariable ID

Definition at line 741 of file scale_comm_cartesC.F90.

746  use scale_prc, only: &
747  prc_abort
748  implicit none
749 
750  character(len=*), intent(in) :: varname
751  real(RP), target, intent(inout) :: var(:,:,:)
752  integer, intent(inout) :: vid
753 
754  integer, intent(in), optional :: gid
755 
756  integer :: gid_
757  integer :: vars_id
758  !---------------------------------------------------------------------------
759 
760  if ( .not. comm_use_mpi_pc ) return
761 #ifdef _OPENACC
762  if ( .not. acc_is_present(var) ) return
763 #endif
764 
765  call prof_rapstart('COMM_init_pers', 2)
766 
767  gid_ = 1
768  if ( present(gid) ) gid_ = gid
769  if ( gid_ > comm_gid_max ) then
770  log_error("COMM_vars_init",*) 'gid is invalid', gid_, comm_gid_max
771  call prc_abort
772  end if
773 
774  if ( vid > comm_vsize_max ) then
775  log_error("COMM_vars_init",*) 'vid exceeds max', vid, comm_vsize_max, gid
776  call prc_abort
777  end if
778 
779  ginfo(gid_)%vars_num = ginfo(gid_)%vars_num + 1
780  if ( ginfo(gid_)%vars_num > comm_vsize_max_pc ) then
781  log_error("COMM_vars_init",*) 'number of variable for MPI PC exceeds max', ginfo(gid_)%vars_num, comm_vsize_max_pc
782  call prc_abort
783  end if
784 
785  vars_id = ginfo(gid_)%vars_num
786  ginfo(gid_)%packid(vars_id) = vid
787 
788 #ifdef _OPENACC
789  if ( .not. acc_is_present(var) ) then
790  ginfo(gid_)%device_alloc(vars_id+comm_vsize_max) = .true.
791  ginfo(gid_)%device_ptr(vars_id*comm_vsize_max)%ptr => var
792  !$acc enter data copyin(var)
793  end if
794 #endif
795 
796  call vars_init_mpi_pc(var, gid_, vars_id, vid)
797 
798  vid = vars_id + comm_vsize_max
799 
800  log_info("COMM_vars_init",'(1x,A,I3.3,A,I3.3,2A)') 'Initialize variable (grid ID = ', gid_, '): ID = ', vid, &
801  ', name = ', trim(varname)
802 
803  call prof_rapend ('COMM_init_pers', 2)
804 
805  return

References scale_prc::prc_abort(), and vars_init_mpi_pc().

Here is the call graph for this function:

◆ comm_vars8_init()

subroutine, public scale_comm_cartesc::comm_vars8_init ( character(len=*), intent(in)  varname,
real(rp), dimension(:,:,:), intent(inout), target  var,
integer, intent(inout)  vid,
integer, intent(in), optional  gid 
)

Register variables.

Parameters
[in]varnamevariable name
[in,out]varvariable array for register
[in,out]vidvariable ID

Definition at line 810 of file scale_comm_cartesC.F90.

815  use scale_prc, only: &
816  prc_abort
817  implicit none
818 
819  character(len=*), intent(in) :: varname
820 
821  real(RP), target, intent(inout) :: var(:,:,:)
822  integer, intent(inout) :: vid
823 
824  integer, intent(in), optional :: gid
825 
826  integer :: gid_
827  integer :: vars_id
828  !---------------------------------------------------------------------------
829 
830  if ( .not. comm_use_mpi_pc ) return
831 #ifdef _OPENACC
832  if ( .not. acc_is_present(var) ) return
833 #endif
834 
835  call prof_rapstart('COMM_init_pers', 2)
836 
837  gid_ = 1
838  if ( present(gid) ) gid_ = gid
839  if ( gid_ > comm_gid_max ) then
840  log_error("COMM_vars8_init",*) 'gid is invalid', gid_, comm_gid_max
841  call prc_abort
842  end if
843 
844  if ( vid > comm_vsize_max ) then
845  log_error("COMM_vars8_init",*) 'vid exceeds max', vid, comm_vsize_max
846  call prc_abort
847  end if
848 
849  ginfo(gid_)%vars_num = ginfo(gid_)%vars_num + 1
850  if ( ginfo(gid_)%vars_num > comm_vsize_max_pc ) then
851  log_error("COMM_vars8_init",*) 'number of variable for MPI PC exceeds max', ginfo(gid_)%vars_num, comm_vsize_max_pc
852  call prc_abort
853  end if
854 
855  vars_id = ginfo(gid_)%vars_num
856  ginfo(gid_)%packid(vars_id) = vid
857 
858 #ifdef _OPENACC
859  if ( .not. acc_is_present(var) ) then
860  ginfo(gid_)%device_alloc(vars_id+comm_vsize_max) = .true.
861  ginfo(gid_)%device_ptr(vars_id+comm_vsize_max)%ptr => var
862  !$acc enter data copyin(var)
863  end if
864 #endif
865 
866  call vars8_init_mpi_pc(var, gid_, vars_id, vid)
867 
868  vid = vars_id + comm_vsize_max
869 
870  log_info("COMM_vars8_init",'(1x,A,I3.3,A,I3.3,2A)') 'Initialize variable (grid ID = ', gid_, '): ID = ', vid, &
871  ', name = ', trim(varname)
872 
873  call prof_rapend ('COMM_init_pers', 2)
874 
875  return

References scale_prc::prc_abort(), and vars8_init_mpi_pc().

Referenced by scale_atmos_dyn_fvm_numfilter::atmos_dyn_fvm_numfilter_setup(), scale_atmos_dyn::atmos_dyn_setup(), scale_atmos_dyn_tinteg_rkcommon::atmos_dyn_tinteg_rkcommon_setup(), scale_atmos_dyn_tinteg_short_rk11s8o::atmos_dyn_tinteg_short_rk11s8o_setup(), scale_atmos_dyn_tinteg_short_rk3::atmos_dyn_tinteg_short_rk3_setup(), scale_atmos_dyn_tinteg_short_rk4::atmos_dyn_tinteg_short_rk4_setup(), scale_atmos_dyn_tinteg_short_rk7s6o::atmos_dyn_tinteg_short_rk7s6o_setup(), scale_atmos_dyn_tinteg_tracer_linrk::atmos_dyn_tinteg_tracer_linrk_setup(), scale_atmos_dyn_tinteg_tracer_rk3::atmos_dyn_tinteg_tracer_rk3_setup(), and scale_atmos_dyn_tstep_large_fvm_heve::atmos_dyn_tstep_large_fvm_heve_setup().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ comm_vars_3d()

subroutine scale_comm_cartesc::comm_vars_3d ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  vid,
integer, intent(in), optional  gid 
)
Parameters
[in,out]varatmospheric 3D variable to communication
[in]vidrequest ID

Definition at line 879 of file scale_comm_cartesC.F90.

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_vars_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 vars_3d_mpi_onesided(var, gid_, vid)
908  else
909  call vars_3d_mpi(var, gid_, vid)
910  end if
911  call prof_rapend ('COMM_vars', 2)
912  end if
913 
914  return

References scale_prc::prc_abort(), vars_3d_mpi(), vars_3d_mpi_onesided(), and vars_3d_mpi_pc().

Here is the call graph for this function:

◆ comm_vars8_3d()

subroutine scale_comm_cartesc::comm_vars8_3d ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  vid,
integer, intent(in), optional  gid 
)

Definition at line 918 of file scale_comm_cartesC.F90.

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  integer, intent(in), optional :: gid
928 
929  integer :: gid_
930  !---------------------------------------------------------------------------
931 
932  gid_ = 1
933  if ( present(gid) ) gid_ = gid
934  if ( gid_ > comm_gid_max ) then
935  log_error("COMM_vars8_3D",*) 'gid is invalid', gid_, comm_gid_max
936  call prc_abort
937  end if
938 
939  if ( vid > comm_vsize_max ) then
940  call prof_rapstart('COMM_vars_pers', 2)
941  call vars_3d_mpi_pc(var, gid_, vid-comm_vsize_max)
942  call prof_rapend ('COMM_vars_pers', 2)
943  else
944  call prof_rapstart('COMM_vars', 2)
945  if ( comm_use_mpi_onesided ) then
946  call vars8_3d_mpi_onesided(var, gid_, vid)
947  else
948  call vars8_3d_mpi(var, gid_, vid)
949  end if
950  call prof_rapend ('COMM_vars', 2)
951  end if
952 
953  return

References scale_prc::prc_abort(), vars8_3d_mpi(), vars8_3d_mpi_onesided(), and vars_3d_mpi_pc().

Here is the call graph for this function:

◆ comm_wait_3d()

subroutine scale_comm_cartesc::comm_wait_3d ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  vid,
logical, intent(in), optional  FILL_BND,
integer, intent(in), optional  gid 
)

Definition at line 957 of file scale_comm_cartesC.F90.

958  use scale_prc, only: &
959  prc_abort
960  implicit none
961 
962  real(RP), intent(inout) :: var(:,:,:)
963 
964  integer, intent(in) :: vid
965 
966  logical, intent(in), optional :: FILL_BND
967  integer, intent(in), optional :: gid
968 
969  logical :: FILL_BND_
970  integer :: gid_
971  !---------------------------------------------------------------------------
972 
973  fill_bnd_ = .true.
974  if ( present(fill_bnd) ) fill_bnd_ = fill_bnd
975 
976  gid_ = 1
977  if ( present(gid) ) gid_ = gid
978  if ( gid_ > comm_gid_max ) then
979  log_error("COMM_wait_3D",*) 'gid is invalid', gid_, comm_gid_max
980  call prc_abort
981  end if
982 
983  if ( vid > comm_vsize_max ) then
984  call prof_rapstart('COMM_wait_pers', 2)
985  call wait_3d_mpi_pc(var, gid_, vid-comm_vsize_max)
986  call prof_rapend ('COMM_wait_pers', 2)
987  else
988  call prof_rapstart('COMM_wait', 2)
989  if ( comm_use_mpi_onesided ) then
990  call wait_3d_mpi_onesided(var, gid_, vid)
991  else
992  call wait_3d_mpi(var, gid_, vid)
993  end if
994  call prof_rapend ('COMM_wait', 2)
995  end if
996 
997  ! copy inner data to boundary
998  if ( .NOT. comm_isallperiodic ) then
999  if ( fill_bnd_ ) then
1000  call copy_boundary_3d(var, gid_)
1001  end if
1002  end if
1003 
1004  return

References scale_prc::prc_abort(), wait_3d_mpi(), wait_3d_mpi_onesided(), and wait_3d_mpi_pc().

Here is the call graph for this function:

◆ comm_vars_2d()

subroutine scale_comm_cartesc::comm_vars_2d ( real(rp), dimension(:,:), intent(inout)  var,
integer, intent(in)  vid,
integer, intent(in), optional  gid 
)

Definition at line 1008 of file scale_comm_cartesC.F90.

1009  use scale_prc, only: &
1010  prc_abort
1011  implicit none
1012 
1013  real(RP), intent(inout) :: var(:,:)
1014 
1015  integer, intent(in) :: vid
1016 
1017  integer, intent(in), optional :: gid
1018 
1019  integer :: gid_
1020  !---------------------------------------------------------------------------
1021 
1022  gid_ = 1
1023  if ( present(gid) ) gid_ = gid
1024  if ( gid_ > comm_gid_max ) then
1025  log_error("COMM_vars_2D",*) 'gid is invalid', gid_, comm_gid_max
1026  call prc_abort
1027  end if
1028 
1029  call prof_rapstart('COMM_vars', 2)
1030  if ( comm_use_mpi_onesided ) then
1031  call vars_2d_mpi_onesided(var, gid_, vid)
1032  else
1033  call vars_2d_mpi(var, gid_, vid)
1034  end if
1035  call prof_rapend ('COMM_vars', 2)
1036 
1037  return

References scale_prc::prc_abort(), vars_2d_mpi(), and vars_2d_mpi_onesided().

Here is the call graph for this function:

◆ comm_vars8_2d()

subroutine scale_comm_cartesc::comm_vars8_2d ( real(rp), dimension(:,:), intent(inout)  var,
integer, intent(in)  vid,
integer, intent(in), optional  gid 
)

Definition at line 1041 of file scale_comm_cartesC.F90.

1042  use scale_prc, only: &
1043  prc_abort
1044  implicit none
1045 
1046  real(RP), intent(inout) :: var(:,:)
1047 
1048  integer, intent(in) :: vid
1049 
1050  integer, intent(in), optional :: gid
1051 
1052  integer :: gid_
1053  !---------------------------------------------------------------------------
1054 
1055  gid_ = 1
1056  if ( present(gid) ) gid_ = gid
1057  if ( gid_ > comm_gid_max ) then
1058  log_error("COMM_vars8_2D",*) 'gid is invalid', gid_, comm_gid_max
1059  call prc_abort
1060  end if
1061 
1062  call prof_rapstart('COMM_vars', 2)
1063  if ( comm_use_mpi_onesided ) then
1064  call vars8_2d_mpi_onesided(var, gid_, vid)
1065  else
1066  call vars8_2d_mpi(var, gid_, vid)
1067  end if
1068  call prof_rapend ('COMM_vars', 2)
1069 
1070  return

References scale_prc::prc_abort(), vars8_2d_mpi(), and vars8_2d_mpi_onesided().

Here is the call graph for this function:

◆ comm_wait_2d()

subroutine scale_comm_cartesc::comm_wait_2d ( real(rp), dimension(:,:), intent(inout)  var,
integer, intent(in)  vid,
logical, intent(in), optional  FILL_BND,
integer, intent(in), optional  gid 
)

Definition at line 1074 of file scale_comm_cartesC.F90.

1075  use scale_prc, only: &
1076  prc_abort
1077  implicit none
1078 
1079  real(RP), intent(inout) :: var(:,:)
1080 
1081  integer, intent(in) :: vid
1082 
1083  logical, intent(in), optional :: FILL_BND
1084  integer, intent(in), optional :: gid
1085 
1086  logical :: FILL_BND_
1087  integer :: gid_
1088  !---------------------------------------------------------------------------
1089 
1090  fill_bnd_ = .true.
1091  if ( present(fill_bnd) ) fill_bnd_ = fill_bnd
1092 
1093  gid_ = 1
1094  if ( present(gid) ) gid_ = gid
1095  if ( gid_ > comm_gid_max ) then
1096  log_error("COMM_wait_2D",*) 'gid is invalid', gid_, comm_gid_max
1097  call prc_abort
1098  end if
1099 
1100  call prof_rapstart('COMM_wait', 2)
1101  if ( comm_use_mpi_onesided ) then
1102  call wait_2d_mpi_onesided(var, gid_, vid)
1103  else
1104  call wait_2d_mpi(var, gid_, vid)
1105  end if
1106  call prof_rapend ('COMM_wait', 2)
1107 
1108  if( .NOT. comm_isallperiodic ) then
1109  if ( fill_bnd_ ) then
1110  call copy_boundary_2d(var, gid_)
1111  end if
1112  end if
1113 
1114  return

References copy_boundary_2d(), scale_prc::prc_abort(), wait_2d_mpi(), and wait_2d_mpi_onesided().

Here is the call graph for this function:

◆ comm_horizontal_mean_2d()

subroutine scale_comm_cartesc::comm_horizontal_mean_2d ( integer, intent(in)  IA,
integer, intent(in)  IS,
integer, intent(in)  IE,
integer, intent(in)  JA,
integer, intent(in)  JS,
integer, intent(in)  JE,
real(rp), dimension(ia,ja), intent(in)  var,
real(rp), intent(out)  varmean 
)

calculate horizontal mean (global total with communication) 2D

Parameters
[in]var2D value
[out]varmeanhorizontal mean

Definition at line 1119 of file scale_comm_cartesC.F90.

1123  use scale_const, only: &
1124  const_undef
1125  implicit none
1126 
1127  integer, intent(in) :: IA, IS, IE
1128  integer, intent(in) :: JA, JS, JE
1129  real(RP), intent(in) :: var(IA,JA)
1130 
1131  real(RP), intent(out) :: varmean
1132 
1133  real(DP) :: stat(2)
1134  real(DP) :: stat1, stat2
1135  real(DP) :: allstat(2)
1136  real(DP) :: zerosw
1137 
1138  integer :: ierr
1139  integer :: i, j
1140  !---------------------------------------------------------------------------
1141 
1142  stat1 = 0.0_dp
1143  stat2 = 0.0_dp
1144  !$omp parallel do reduction(+:stat1,stat2)
1145  !$acc kernels if(acc_is_present(var))
1146  !$acc loop reduction(+:stat1,stat2)
1147  do j = js, je
1148  !$acc loop reduction(+:stat1,stat2)
1149  do i = is, ie
1150  if ( abs(var(i,j)) < abs(const_undef) ) then
1151  stat1 = stat1 + var(i,j)
1152  stat2 = stat2 + 1.0_dp
1153  endif
1154  enddo
1155  enddo
1156  !$acc end kernels
1157 
1158  stat(:) = (/stat1, stat2/)
1159 
1160  ! All reduce
1161  ! [NOTE] always communicate globally
1162  call prof_rapstart('COMM_Allreduce', 2)
1163  call mpi_allreduce( stat, &
1164  allstat, &
1165  2, &
1166  mpi_double_precision, &
1167  mpi_sum, &
1168  comm_world_t, &
1169  ierr )
1170  call prof_rapend ('COMM_Allreduce', 2)
1171 
1172  zerosw = 0.5_dp - sign(0.5_dp, allstat(1) - 1.e-12_dp )
1173  varmean = allstat(1) / ( allstat(2) + zerosw ) * ( 1.0_dp - zerosw )
1174  !LOG_INFO("COMM_horizontal_mean_2D",*) varmean, allstat(1), allstat(2)
1175 
1176  return
scale_const
module CONSTANT
Definition: scale_const.F90:11
scale_const::const_undef
real(rp), public const_undef
Definition: scale_const.F90:43

References scale_const::const_undef.

◆ comm_horizontal_mean_3d()

subroutine scale_comm_cartesc::comm_horizontal_mean_3d ( integer, intent(in)  KA,
integer, intent(in)  IA,
integer, intent(in)  IS,
integer, intent(in)  IE,
integer, intent(in)  JA,
integer, intent(in)  JS,
integer, intent(in)  JE,
real(rp), dimension(ka,ia,ja), intent(in)  var,
real(rp), dimension(ka), intent(out)  varmean 
)

calculate horizontal mean (global total with communication) 3D

Parameters
[in]var3D value
[out]varmeanhorizontal mean

Definition at line 1181 of file scale_comm_cartesC.F90.

1185  use scale_const, only: &
1186  const_undef
1187  implicit none
1188 
1189  integer, intent(in) :: KA
1190  integer, intent(in) :: IA, IS, IE
1191  integer, intent(in) :: JA, JS, JE
1192  real(RP), intent(in) :: var(KA,IA,JA)
1193 
1194  real(RP), intent(out) :: varmean(KA)
1195 
1196  real(DP) :: stat (KA,2)
1197  real(DP) :: allstat(KA,2)
1198  real(DP) :: zerosw
1199 
1200  integer :: ierr
1201  integer :: k, i, j
1202 #ifdef _OPENACC
1203  logical :: flag_device
1204 #endif
1205  !---------------------------------------------------------------------------
1206 
1207 #ifdef _OPENACC
1208  flag_device = acc_is_present(var)
1209 #endif
1210 
1211  !$acc data create(stat, allstat) if(flag_device)
1212 
1213  !$acc kernels if(flag_device)
1214  stat(:,:) = 0.0_dp
1215  !$acc end kernels
1216  !$acc kernels if(flag_device)
1217  !$acc loop independent
1218  do j = js, je
1219  !$acc loop independent
1220  do i = is, ie
1221  do k = 1, ka
1222  if ( abs(var(k,i,j)) < abs(const_undef) ) then
1223  !$acc atomic update
1224  stat(k,1) = stat(k,1) + var(k,i,j)
1225  !$acc end atomic
1226  !$acc atomic update
1227  stat(k,2) = stat(k,2) + 1.0_dp
1228  !$acc end atomic
1229  endif
1230  enddo
1231  enddo
1232  enddo
1233  !$acc end kernels
1234 
1235 
1236  ! All reduce
1237  ! [NOTE] always communicate globally
1238  call prof_rapstart('COMM_Allreduce', 2)
1239  !$acc host_data use_device(stat, allstat) if(flag_device)
1240  call mpi_allreduce( stat, &
1241  allstat, &
1242  ka * 2, &
1243  mpi_double_precision, &
1244  mpi_sum, &
1245  comm_world_t, &
1246  ierr )
1247  !$acc end host_data
1248  call prof_rapend ('COMM_Allreduce', 2)
1249 
1250  !$acc kernels if(flag_device)
1251  do k = 1, ka
1252  zerosw = 0.5_dp - sign(0.5_dp, allstat(k,2) - 1.e-12_dp )
1253  varmean(k) = allstat(k,1) / ( allstat(k,2) + zerosw ) * ( 1.0_dp - zerosw )
1254  !LOG_INFO("COMM_horizontal_mean_3D",*) k, varmean(k), allstatval(k), allstatcnt(k)
1255  enddo
1256  !$acc end kernels
1257 
1258  !$acc end data
1259 
1260  return

References scale_const::const_undef.

◆ comm_gather_2d()

subroutine scale_comm_cartesc::comm_gather_2d ( integer, intent(in)  IA,
integer, intent(in)  JA,
real(rp), dimension(ia,ja), intent(in)  send,
real(rp), dimension(:,:,:), intent(out)  recv 
)

Get data from whole process value in 2D field.

Parameters
[in]jadimension size
[in]sendsend buffer
[out]recvreceive buffer (IA,JA,nprcs)

Definition at line 1265 of file scale_comm_cartesC.F90.

1269  use scale_prc, only: &
1270  prc_masterrank
1271  implicit none
1272 
1273  integer, intent(in) :: IA, JA
1274  real(RP), intent(in) :: send(IA,JA)
1275 
1276  real(RP), intent(out) :: recv(:,:,:)
1277 
1278  integer :: sendcounts, recvcounts
1279  integer :: ierr
1280  !---------------------------------------------------------------------------
1281 
1282  sendcounts = ia * ja
1283  recvcounts = ia * ja
1284 
1285  !$acc host_data use_device(send, recv) if(acc_is_present(send))
1286  call mpi_gather( send(:,:), &
1287  sendcounts, &
1288  comm_datatype_t, &
1289  recv(:,:,:), &
1290  recvcounts, &
1291  comm_datatype_t, &
1292  prc_masterrank, &
1293  comm_world_t, &
1294  ierr )
1295  !$acc end host_data
1296 
1297  return
scale_prc::prc_masterrank
integer, parameter, public prc_masterrank
master process in each communicator
Definition: scale_prc.F90:67

References scale_prc::prc_masterrank.

◆ comm_gather_3d()

subroutine scale_comm_cartesc::comm_gather_3d ( integer, intent(in)  KA,
integer, intent(in)  IA,
integer, intent(in)  JA,
real(rp), dimension(ka,ia,ja), intent(in)  send,
real(rp), dimension(:,:,:,:), intent(out)  recv 
)

Get data from whole process value in 3D field.

Parameters
[in]jadimension size
[in]sendsend buffer
[out]recvreceive buffer(KA,IA,JA,nprcs)

Definition at line 1302 of file scale_comm_cartesC.F90.

1306  use scale_prc, only: &
1307  prc_masterrank
1308  implicit none
1309 
1310  integer, intent(in) :: KA, IA, JA
1311  real(RP), intent(in) :: send(KA,IA,JA)
1312 
1313  real(RP), intent(out) :: recv(:,:,:,:)
1314 
1315  integer :: sendcounts, recvcounts
1316  integer :: ierr
1317  !---------------------------------------------------------------------------
1318 
1319  sendcounts = ka * ia * ja
1320  recvcounts = ka * ia * ja
1321 
1322  !$acc host_data use_device(send, recv) if(acc_is_present(send))
1323  call mpi_gather( send(:,:,:), &
1324  sendcounts, &
1325  comm_datatype_t, &
1326  recv(:,:,:,:), &
1327  recvcounts, &
1328  comm_datatype_t, &
1329  prc_masterrank, &
1330  comm_world_t, &
1331  ierr )
1332  !$acc end host_data
1333 
1334  return

References scale_prc::prc_masterrank.

◆ comm_bcast_scr_sp()

subroutine scale_comm_cartesc::comm_bcast_scr_sp ( real(sp), intent(inout)  var)

Broadcast data for whole process value in scalar field.

Parameters
[in,out]varbroadcast buffer

Definition at line 1339 of file scale_comm_cartesC.F90.

1340  use scale_prc, only: &
1341  prc_masterrank
1342  implicit none
1343 
1344  real(SP), intent(inout) :: var
1345 
1346  integer :: counts
1347  integer :: ierr
1348  !---------------------------------------------------------------------------
1349 
1350  call prof_rapstart('COMM_Bcast', 2)
1351 
1352  counts = 1
1353 
1354  call mpi_bcast( var, &
1355  counts, &
1356  mpi_real, &
1357  prc_masterrank, &
1358  comm_world_t, &
1359  ierr )
1360 
1361  call prof_rapend('COMM_Bcast', 2)
1362 
1363  return

References scale_prc::prc_masterrank.

◆ comm_bcast_scr_dp()

subroutine scale_comm_cartesc::comm_bcast_scr_dp ( real(dp), intent(inout)  var)
Parameters
[in,out]varbroadcast buffer

Definition at line 1365 of file scale_comm_cartesC.F90.

1366  use scale_prc, only: &
1367  prc_masterrank
1368  implicit none
1369 
1370  real(DP), intent(inout) :: var
1371 
1372  integer :: counts
1373  integer :: ierr
1374  !---------------------------------------------------------------------------
1375 
1376  call prof_rapstart('COMM_Bcast', 2)
1377 
1378  counts = 1
1379 
1380  call mpi_bcast( var, &
1381  counts, &
1382  mpi_double_precision, &
1383  prc_masterrank, &
1384  comm_world_t, &
1385  ierr )
1386 
1387  call prof_rapend('COMM_Bcast', 2)
1388 
1389  return

References scale_prc::prc_masterrank.

◆ comm_bcast_1d_sp()

subroutine scale_comm_cartesc::comm_bcast_1d_sp ( integer, intent(in)  IA,
real(sp), dimension(ia), intent(inout)  var 
)

Broadcast data for whole process value in 1D field.

Parameters
[in]iadimension size
[in,out]varbroadcast buffer

Definition at line 1394 of file scale_comm_cartesC.F90.

1395  use scale_prc, only: &
1396  prc_masterrank
1397  implicit none
1398 
1399  integer, intent(in) :: IA
1400 
1401  real(SP), intent(inout) :: var(IA)
1402 
1403  integer :: counts
1404  integer :: ierr
1405  !---------------------------------------------------------------------------
1406 
1407  call prof_rapstart('COMM_Bcast', 2)
1408 
1409  counts = ia
1410 
1411  !$acc host_data use_device(var) if(acc_is_present(var))
1412  call mpi_bcast( var(:), &
1413  counts, &
1414  mpi_real, &
1415  prc_masterrank, &
1416  comm_world_t, &
1417  ierr )
1418  !$acc end host_data
1419 
1420  call prof_rapend('COMM_Bcast', 2)
1421 
1422  return

References scale_prc::prc_masterrank.

◆ comm_bcast_1d_dp()

subroutine scale_comm_cartesc::comm_bcast_1d_dp ( integer, intent(in)  IA,
real(dp), dimension(ia), intent(inout)  var 
)
Parameters
[in]iadimension size
[in,out]varbroadcast buffer

Definition at line 1424 of file scale_comm_cartesC.F90.

1425  use scale_prc, only: &
1426  prc_masterrank
1427  implicit none
1428 
1429  integer, intent(in) :: IA
1430 
1431  real(DP), intent(inout) :: var(IA)
1432 
1433  integer :: counts
1434  integer :: ierr
1435  !---------------------------------------------------------------------------
1436 
1437  call prof_rapstart('COMM_Bcast', 2)
1438 
1439  counts = ia
1440 
1441  !$acc host_data use_device(var) if(acc_is_present(var))
1442  call mpi_bcast( var(:), &
1443  counts, &
1444  mpi_double_precision, &
1445  prc_masterrank, &
1446  comm_world_t, &
1447  ierr )
1448  !$acc end host_data
1449 
1450  call prof_rapend('COMM_Bcast', 2)
1451 
1452  return

References scale_prc::prc_masterrank.

◆ comm_bcast_2d_sp()

subroutine scale_comm_cartesc::comm_bcast_2d_sp ( integer, intent(in)  IA,
integer, intent(in)  JA,
real(sp), dimension(ia,ja), intent(inout)  var 
)

Broadcast data for whole process value in 2D field.

Parameters
[in]jadimension size
[in,out]varbroadcast buffer

Definition at line 1457 of file scale_comm_cartesC.F90.

1458  use scale_prc, only: &
1459  prc_masterrank
1460  implicit none
1461 
1462  integer, intent(in) :: IA, JA
1463 
1464  real(SP), intent(inout) :: var(IA,JA)
1465 
1466  integer :: counts
1467  integer :: ierr
1468  !---------------------------------------------------------------------------
1469 
1470  call prof_rapstart('COMM_Bcast', 2)
1471 
1472  counts = ia * ja
1473 
1474  !$acc host_data use_device(var) if(acc_is_present(var))
1475  call mpi_bcast( var(:,:), &
1476  counts, &
1477  mpi_real, &
1478  prc_masterrank, &
1479  comm_world_t, &
1480  ierr )
1481  !$acc end host_data
1482 
1483  call prof_rapend('COMM_Bcast', 2)
1484 
1485  return

References scale_prc::prc_masterrank.

◆ comm_bcast_2d_dp()

subroutine scale_comm_cartesc::comm_bcast_2d_dp ( integer, intent(in)  IA,
integer, intent(in)  JA,
real(dp), dimension(ia,ja), intent(inout)  var 
)
Parameters
[in]jadimension size
[in,out]varbroadcast buffer

Definition at line 1487 of file scale_comm_cartesC.F90.

1488  use scale_prc, only: &
1489  prc_masterrank
1490  implicit none
1491 
1492  integer, intent(in) :: IA, JA
1493 
1494  real(DP), intent(inout) :: var(IA,JA)
1495 
1496  integer :: counts
1497  integer :: ierr
1498  !---------------------------------------------------------------------------
1499 
1500  call prof_rapstart('COMM_Bcast', 2)
1501 
1502  counts = ia * ja
1503 
1504  !$acc host_data use_device(var) if(acc_is_present(var))
1505  call mpi_bcast( var(:,:), &
1506  counts, &
1507  mpi_double_precision, &
1508  prc_masterrank, &
1509  comm_world_t, &
1510  ierr )
1511  !$acc end host_data
1512 
1513  call prof_rapend('COMM_Bcast', 2)
1514 
1515  return

References scale_prc::prc_masterrank.

◆ comm_bcast_3d_sp()

subroutine scale_comm_cartesc::comm_bcast_3d_sp ( integer, intent(in)  KA,
integer, intent(in)  IA,
integer, intent(in)  JA,
real(sp), dimension(ka,ia,ja), intent(inout)  var 
)

Broadcast data for whole process value in 3D field.

Parameters
[in]jadimension size
[in,out]varbroadcast buffer

Definition at line 1520 of file scale_comm_cartesC.F90.

1521  use scale_prc, only: &
1522  prc_masterrank
1523  implicit none
1524 
1525  integer, intent(in) :: KA, IA, JA
1526 
1527  real(SP), intent(inout) :: var(KA,IA,JA)
1528 
1529  integer :: counts
1530  integer :: ierr
1531  !---------------------------------------------------------------------------
1532 
1533  call prof_rapstart('COMM_Bcast', 2)
1534 
1535  counts = ka * ia * ja
1536 
1537  !$acc host_data use_device(var) if(acc_is_present(var))
1538  call mpi_bcast( var(:,:,:), &
1539  counts, &
1540  mpi_real, &
1541  prc_masterrank, &
1542  comm_world_t, &
1543  ierr )
1544  !$acc end host_data
1545 
1546  call prof_rapend('COMM_Bcast', 2)
1547 
1548  return

References scale_prc::prc_masterrank.

◆ comm_bcast_3d_dp()

subroutine scale_comm_cartesc::comm_bcast_3d_dp ( integer, intent(in)  KA,
integer, intent(in)  IA,
integer, intent(in)  JA,
real(dp), dimension(ka,ia,ja), intent(inout)  var 
)
Parameters
[in]jadimension size
[in,out]varbroadcast buffer

Definition at line 1550 of file scale_comm_cartesC.F90.

1551  use scale_prc, only: &
1552  prc_masterrank
1553  implicit none
1554 
1555  integer, intent(in) :: KA, IA, JA
1556 
1557  real(DP), intent(inout) :: var(KA,IA,JA)
1558 
1559  integer :: counts
1560  integer :: ierr
1561  !---------------------------------------------------------------------------
1562 
1563  call prof_rapstart('COMM_Bcast', 2)
1564 
1565  counts = ka * ia * ja
1566 
1567  !$acc host_data use_device(var) if(acc_is_present(var))
1568  call mpi_bcast( var(:,:,:), &
1569  counts, &
1570  mpi_double_precision, &
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

References scale_prc::prc_masterrank.

◆ comm_bcast_4d_sp()

subroutine scale_comm_cartesc::comm_bcast_4d_sp ( integer, intent(in)  KA,
integer, intent(in)  IA,
integer, intent(in)  JA,
integer, intent(in)  NT,
real(sp), dimension(ka,ia,ja,nt), intent(inout)  var 
)

Broadcast data for whole process value in 4D field.

Parameters
[in]ntdimension size
[in,out]varbroadcast buffer

Definition at line 1583 of file scale_comm_cartesC.F90.

1584  use scale_prc, only: &
1585  prc_abort, &
1586  prc_masterrank
1587  implicit none
1588 
1589  integer, intent(in) :: KA, IA, JA, NT
1590 
1591  real(SP), intent(inout) :: var(KA,IA,JA,NT)
1592 
1593  integer :: counts
1594  integer :: ierr
1595  !---------------------------------------------------------------------------
1596 
1597  call prof_rapstart('COMM_Bcast', 2)
1598 
1599  counts = ka * ia * ja * nt
1600  if ( ka>0 .AND. ia>0 .AND. ja>0 .AND. nt>0 .AND. &
1601  counts < 0 ) then
1602  log_error("COMM_bcast_4D",*) 'counts overflow'
1603  call prc_abort
1604  end if
1605 
1606  !$acc host_data use_device(var) if(acc_is_present(var))
1607  call mpi_bcast( var(:,:,:,:), &
1608  counts, &
1609  mpi_real, &
1610  prc_masterrank, &
1611  comm_world_t, &
1612  ierr )
1613  !$acc end host_data
1614 
1615  call prof_rapend('COMM_Bcast', 2)
1616 
1617  return

References scale_prc::prc_abort(), and scale_prc::prc_masterrank.

Here is the call graph for this function:

◆ comm_bcast_4d_dp()

subroutine scale_comm_cartesc::comm_bcast_4d_dp ( integer, intent(in)  KA,
integer, intent(in)  IA,
integer, intent(in)  JA,
integer, intent(in)  NT,
real(dp), dimension(ka,ia,ja,nt), intent(inout)  var 
)
Parameters
[in]ntdimension size
[in,out]varbroadcast buffer

Definition at line 1619 of file scale_comm_cartesC.F90.

1620  use scale_prc, only: &
1621  prc_abort, &
1622  prc_masterrank
1623  implicit none
1624 
1625  integer, intent(in) :: KA, IA, JA, NT
1626 
1627  real(DP), intent(inout) :: var(KA,IA,JA,NT)
1628 
1629  integer :: counts
1630  integer :: ierr
1631  !---------------------------------------------------------------------------
1632 
1633  call prof_rapstart('COMM_Bcast', 2)
1634 
1635  counts = ka * ia * ja * nt
1636  if ( ka>0 .AND. ia>0 .AND. ja>0 .AND. nt>0 .AND. &
1637  counts < 0 ) then
1638  log_error("COMM_bcast_4D",*) 'counts overflow'
1639  call prc_abort
1640  end if
1641 
1642  !$acc host_data use_device(var) if(acc_is_present(var))
1643  call mpi_bcast( var(:,:,:,:), &
1644  counts, &
1645  mpi_double_precision, &
1646  prc_masterrank, &
1647  comm_world_t, &
1648  ierr )
1649  !$acc end host_data
1650 
1651  call prof_rapend('COMM_Bcast', 2)
1652 
1653  return

References scale_prc::prc_abort(), and scale_prc::prc_masterrank.

Here is the call graph for this function:

◆ comm_bcast_int_scr()

subroutine scale_comm_cartesc::comm_bcast_int_scr ( integer, intent(inout)  var)

Broadcast data for whole process value in scalar (integer)

Parameters
[in,out]varbroadcast buffer

Definition at line 1658 of file scale_comm_cartesC.F90.

1659  use scale_prc, only: &
1660  prc_masterrank
1661  implicit none
1662 
1663  integer, intent(inout) :: var
1664 
1665  integer :: counts
1666  integer :: ierr
1667  !---------------------------------------------------------------------------
1668 
1669  call prof_rapstart('COMM_Bcast', 2)
1670 
1671  counts = 1
1672 
1673  call mpi_bcast( var, &
1674  counts, &
1675  mpi_integer, &
1676  prc_masterrank, &
1677  comm_world_t, &
1678  ierr )
1679 
1680  call prof_rapend('COMM_Bcast', 2)
1681 
1682  return

References scale_prc::prc_masterrank.

◆ comm_bcast_int_1d()

subroutine scale_comm_cartesc::comm_bcast_int_1d ( integer, intent(in)  IA,
integer, dimension(ia), intent(inout)  var 
)

Broadcast data for whole process value in 1D field (integer)

Parameters
[in]iadimension size
[in,out]varbroadcast buffer

Definition at line 1687 of file scale_comm_cartesC.F90.

1688  use scale_prc, only: &
1689  prc_masterrank
1690  implicit none
1691 
1692  integer, intent(in) :: IA
1693  integer, intent(inout) :: var(IA)
1694 
1695  integer :: counts
1696  integer :: ierr
1697  !---------------------------------------------------------------------------
1698 
1699  call prof_rapstart('COMM_Bcast', 2)
1700 
1701  counts = ia
1702 
1703  call mpi_bcast( var(:), &
1704  counts, &
1705  mpi_integer, &
1706  prc_masterrank, &
1707  comm_world_t, &
1708  ierr )
1709 
1710  call prof_rapend('COMM_Bcast', 2)
1711 
1712  return

References scale_prc::prc_masterrank.

◆ comm_bcast_int_2d()

subroutine scale_comm_cartesc::comm_bcast_int_2d ( integer, intent(in)  IA,
integer, intent(in)  JA,
integer, dimension(ia,ja), intent(inout)  var 
)

Broadcast data for whole process value in 2D field (integer)

Parameters
[in]jadimension size
[in,out]varbroadcast buffer

Definition at line 1717 of file scale_comm_cartesC.F90.

1718  use scale_prc, only: &
1719  prc_masterrank
1720  implicit none
1721 
1722  integer, intent(in) :: IA, JA
1723 
1724  integer, intent(inout) :: var(IA,JA)
1725 
1726  integer :: counts
1727  integer :: ierr
1728  !---------------------------------------------------------------------------
1729 
1730  call prof_rapstart('COMM_Bcast', 2)
1731 
1732  counts = ia * ja
1733 
1734  !$acc host_data use_device(var) if(acc_is_present(var))
1735  call mpi_bcast( var(:,:), &
1736  counts, &
1737  mpi_integer, &
1738  prc_masterrank, &
1739  comm_world_t, &
1740  ierr )
1741  !$acc end host_data
1742 
1743  call prof_rapend('COMM_Bcast', 2)
1744 
1745  return

References scale_prc::prc_masterrank.

◆ comm_bcast_logical_scr()

subroutine scale_comm_cartesc::comm_bcast_logical_scr ( logical, intent(inout)  var)

Broadcast data for whole process value in scalar (logical)

Parameters
[in,out]varbroadcast buffer

Definition at line 1750 of file scale_comm_cartesC.F90.

1751  use scale_prc, only: &
1752  prc_masterrank
1753  implicit none
1754 
1755  logical, intent(inout) :: var
1756 
1757  integer :: counts
1758  integer :: ierr
1759  !---------------------------------------------------------------------------
1760 
1761  call prof_rapstart('COMM_Bcast', 2)
1762 
1763  counts = 1
1764 
1765  call mpi_bcast( var, &
1766  counts, &
1767  mpi_logical, &
1768  prc_masterrank, &
1769  comm_world_t, &
1770  ierr )
1771 
1772  call prof_rapend('COMM_Bcast', 2)
1773 
1774  return

References scale_prc::prc_masterrank.

◆ comm_bcast_logical_1d()

subroutine scale_comm_cartesc::comm_bcast_logical_1d ( integer, intent(in)  IA,
logical, dimension(ia), intent(inout)  var 
)

Broadcast data for whole process value in 1D (logical)

Parameters
[in]iadimension size
[in,out]varbroadcast buffer

Definition at line 1779 of file scale_comm_cartesC.F90.

1780  use scale_prc, only: &
1781  prc_masterrank
1782  implicit none
1783 
1784  integer, intent(in) :: IA
1785  logical, intent(inout) :: var(IA)
1786 
1787  integer :: counts
1788  integer :: ierr
1789  !---------------------------------------------------------------------------
1790 
1791  call prof_rapstart('COMM_Bcast', 2)
1792 
1793  counts = ia
1794 
1795  !$acc host_data use_device(var) if(acc_is_present(var))
1796  call mpi_bcast( var(:), &
1797  counts, &
1798  mpi_logical, &
1799  prc_masterrank, &
1800  comm_world_t, &
1801  ierr )
1802  !$acc end host_data
1803 
1804  call prof_rapend('COMM_Bcast', 2)
1805 
1806  return

References scale_prc::prc_masterrank.

◆ comm_bcast_character()

subroutine scale_comm_cartesc::comm_bcast_character ( character(len=*), intent(inout)  var)

Broadcast data for whole process value in character.

Parameters
[in,out]varbroadcast buffer

Definition at line 1811 of file scale_comm_cartesC.F90.

1812  use scale_prc, only: &
1813  prc_masterrank
1814  implicit none
1815 
1816  character(len=*), intent(inout) :: var
1817 
1818  integer :: counts
1819  integer :: ierr
1820  !---------------------------------------------------------------------------
1821 
1822  call prof_rapstart('COMM_Bcast', 2)
1823 
1824  counts = len(var)
1825 
1826  call mpi_bcast( var, &
1827  counts, &
1828  mpi_character, &
1829  prc_masterrank, &
1830  comm_world_t, &
1831  ierr )
1832 
1833  call prof_rapend('COMM_Bcast', 2)
1834 
1835  return

References scale_prc::prc_masterrank.

◆ vars_init_mpi_pc()

subroutine scale_comm_cartesc::vars_init_mpi_pc ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid,
integer, intent(in)  seqid 
)

Definition at line 1841 of file scale_comm_cartesC.F90.

1842  use scale_prc_cartesc, only: &
1843  prc_twod
1844  implicit none
1845 
1846  real(RP), intent(inout) :: var(:,:,:)
1847  integer, intent(in) :: gid
1848  integer, intent(in) :: vid
1849  integer, intent(in) :: seqid
1850 
1851  integer :: ireq, tag, ierr
1852  logical :: flag
1853 
1854  integer :: KA
1855  integer :: JA, JS, JE, JHALO
1856 
1857  integer :: nreq
1858  integer :: i
1859 
1860 #ifdef _OPENACC
1861  real(RP), pointer :: ptr(:,:)
1862 #endif
1863 
1864  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
1865  ireq = 1
1866 
1867  ka = ginfo(gid)%KA
1868  ja = ginfo(gid)%JA
1869  js = ginfo(gid)%JS
1870  je = ginfo(gid)%JE
1871  jhalo = ginfo(gid)%JHALO
1872 
1873  !$acc host_data use_device(var)
1874 
1875  ! register whole array to inner table of MPI and/or lower library
1876  ! otherwise a lot of sub small segments would be registered
1877  call mpi_send_init( var(:,:,:), size(var), comm_datatype_t, &
1878  mpi_proc_null, tag+ginfo(gid)%nreq_max+1, comm_world_t, &
1879  ginfo(gid)%preq_list(ginfo(gid)%nreq_max+1,vid), ierr )
1880 
1881  !--- From 4-Direction HALO communicate
1882  ! From S
1883  if ( prc_has_s ) then
1884  call mpi_recv_init( var(:,:,1:js-1), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
1885  prc_next(prc_s), tag+1, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1886  ireq = ireq + 1
1887  end if
1888  ! From N
1889  if ( prc_has_n ) then
1890  call mpi_recv_init( var(:,:,je+1:ja), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
1891  prc_next(prc_n), tag+2, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1892  ireq = ireq + 1
1893  end if
1894  if ( .not. prc_twod ) then
1895 #ifdef _OPENACC
1896  ptr => ginfo(gid)%recvpack_WE2P(:,:,seqid)
1897  !$acc host_data use_device(ptr)
1898 #endif
1899 
1900  ! From E
1901  if ( prc_has_e ) then
1902 #ifdef _OPENACC
1903  call mpi_recv_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1904 #else
1905  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1906 #endif
1907  prc_next(prc_e), tag+3, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1908  ireq = ireq + 1
1909  end if
1910  ! From W
1911  if ( prc_has_w ) then
1912 #ifdef _OPENACC
1913  call mpi_recv_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1914 #else
1915  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1916 #endif
1917  prc_next(prc_w), tag+4, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1918  ireq = ireq + 1
1919  end if
1920  !$acc end host_data
1921  end if
1922 
1923  !--- To 4-Direction HALO communicate
1924  if ( .not. prc_twod ) then
1925 #ifdef _OPENACC
1926  ptr => ginfo(gid)%sendpack_P2WE(:,:,seqid)
1927  !$acc host_data use_device(ptr)
1928 #endif
1929  ! To W HALO
1930  if ( prc_has_w ) then
1931 #ifdef _OPENACC
1932  call mpi_send_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1933 #else
1934  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1935 #endif
1936  prc_next(prc_w), tag+3, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1937  ireq = ireq + 1
1938  end if
1939  ! To E HALO
1940  if ( prc_has_e ) then
1941 #ifdef _OPENACC
1942  call mpi_send_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1943 #else
1944  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
1945 #endif
1946  prc_next(prc_e), tag+4, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1947  ireq = ireq + 1
1948  end if
1949  !$acc end host_data
1950  end if
1951  ! To N HALO
1952  if ( prc_has_n ) then
1953  call mpi_send_init( var(:,:,je-jhalo+1:je), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
1954  prc_next(prc_n), tag+1, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1955  ireq = ireq + 1
1956  end if
1957  ! To S HALO
1958  if ( prc_has_s ) then
1959  call mpi_send_init( var(:,:,js:js+jhalo-1), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
1960  prc_next(prc_s), tag+2, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
1961  ireq = ireq + 1
1962  end if
1963 
1964  ginfo(gid)%preq_cnt(vid) = ireq - 1
1965 
1966  ! to finish initial processes of MPI
1967  nreq = ginfo(gid)%preq_cnt(vid)
1968  do i = 1, 32
1969  call mpi_testall( nreq, ginfo(gid)%preq_list(1:nreq,vid), &
1970  flag, mpi_statuses_ignore, ierr )
1971  enddo
1972 
1973  !$acc end host_data
1974 
1975  return

References scale_prc_cartesc::prc_twod.

Referenced by comm_vars_init().

Here is the caller graph for this function:

◆ vars8_init_mpi_pc()

subroutine scale_comm_cartesc::vars8_init_mpi_pc ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid,
integer, intent(in)  seqid 
)

Definition at line 1978 of file scale_comm_cartesC.F90.

1979  use scale_prc_cartesc, only: &
1980  prc_twod
1981  implicit none
1982 
1983  real(RP), intent(inout) :: var(:,:,:)
1984  integer, intent(in) :: gid
1985  integer, intent(in) :: vid
1986  integer, intent(in) :: seqid
1987 
1988  integer :: ireq, tag, tagc
1989  integer :: ierr
1990  logical :: flag
1991 
1992  integer :: KA
1993  integer :: IS, IE, IHALO
1994  integer :: JA, JS, JE, JHALO
1995 
1996  integer :: nreq
1997  integer :: i, j
1998 
1999 #ifdef _OPENACC
2000  real(RP), pointer :: ptr(:,:)
2001 #endif
2002 
2003  ka = ginfo(gid)%KA
2004  is = ginfo(gid)%IS
2005  ie = ginfo(gid)%IE
2006  ihalo = ginfo(gid)%IHALO
2007  ja = ginfo(gid)%JA
2008  js = ginfo(gid)%JS
2009  je = ginfo(gid)%JE
2010  jhalo = ginfo(gid)%JHALO
2011 
2012  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
2013  ireq = 1
2014 
2015  !$acc host_data use_device(var)
2016 
2017  ! register whole array to inner table of MPI and/or lower library
2018  ! otherwise a lot of sub small segments would be registered
2019  call mpi_send_init( var(:,:,:), size(var), comm_datatype_t, &
2020  mpi_proc_null, tag+ginfo(gid)%nreq_max+1, comm_world_t, &
2021  ginfo(gid)%preq_list(ginfo(gid)%nreq_max+1,vid), ierr )
2022 
2023 
2024  if ( comm_isallperiodic ) then ! periodic condition
2025 
2026  !--- From 8-Direction HALO communicate
2027  if ( .not. prc_twod ) then
2028  ! From SE
2029  tagc = 0
2030  do j = 1, js-1
2031  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2032  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2033  ireq = ireq + 1
2034  tagc = tagc + 1
2035  enddo
2036  ! From SW
2037  tagc = 10
2038  do j = 1, js-1
2039  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2040  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2041  ireq = ireq + 1
2042  tagc = tagc + 1
2043  enddo
2044  ! From NE
2045  tagc = 20
2046  do j = je+1, ja
2047  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2048  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2049  ireq = ireq + 1
2050  tagc = tagc + 1
2051  enddo
2052  ! From NW
2053  tagc = 30
2054  do j = je+1, je+jhalo
2055  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2056  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2057  ireq = ireq + 1
2058  tagc = tagc + 1
2059  enddo
2060  ! From E
2061  tagc = 60
2062 #ifdef _OPENACC
2063  ptr => ginfo(gid)%recvpack_WE2P(:,:,seqid)
2064  !$acc host_data use_device(ptr)
2065  call mpi_recv_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2066 #else
2067  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2068 #endif
2069  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2070  ireq = ireq + 1
2071  ! From W
2072  tagc = 70
2073 #ifdef _OPENACC
2074  call mpi_recv_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2075 #else
2076  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2077 #endif
2078  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2079  !$acc end host_data
2080  ireq = ireq + 1
2081  end if
2082  ! From S
2083  tagc = 40
2084  do j = 1, js-1
2085  call mpi_recv_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2086  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2087  ireq = ireq + 1
2088  tagc = tagc + 1
2089  enddo
2090  ! From N
2091  tagc = 50
2092  do j = je+1, ja
2093  call mpi_recv_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2094  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2095  ireq = ireq + 1
2096  tagc = tagc + 1
2097  enddo
2098 
2099  !--- To 8-Direction HALO communicate
2100  ! To N HALO
2101  tagc = 40
2102  do j = je-jhalo+1, je
2103  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2104  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2105  ireq = ireq + 1
2106  tagc = tagc + 1
2107  enddo
2108  ! To S HALO
2109  tagc = 50
2110  do j = js, js+jhalo-1
2111  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2112  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2113  ireq = ireq + 1
2114  tagc = tagc + 1
2115  enddo
2116  if ( .not. prc_twod ) then
2117  ! To W HALO
2118  tagc = 60
2119 #ifdef _OPENACC
2120  ptr => ginfo(gid)%sendpack_P2WE(:,:,seqid)
2121  !$acc host_data use_device(ptr)
2122  call mpi_send_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2123 #else
2124  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2125 #endif
2126  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2127  ireq = ireq + 1
2128  ! To E HALO
2129  tagc = 70
2130 #ifdef _OPENACC
2131  call mpi_send_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2132 #else
2133  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2134 #endif
2135  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2136  !$acc end host_data
2137  ireq = ireq + 1
2138  ! To NW HALO
2139  tagc = 0
2140  do j = je-jhalo+1, je
2141  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2142  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2143  ireq = ireq + 1
2144  tagc = tagc + 1
2145  enddo
2146  ! To NE HALO
2147  tagc = 10
2148  do j = je-jhalo+1, je
2149  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2150  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2151  ireq = ireq + 1
2152  tagc = tagc + 1
2153  enddo
2154  ! To SW HALO
2155  tagc = 20
2156  do j = js, js+jhalo-1
2157  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2158  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2159  ireq = ireq + 1
2160  tagc = tagc + 1
2161  enddo
2162  ! To SE HALO
2163  tagc = 30
2164  do j = js, js+jhalo-1
2165  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2166  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2167  ireq = ireq + 1
2168  tagc = tagc + 1
2169  enddo
2170  end if
2171 
2172  else ! non-periodic condition
2173 
2174  !--- From 8-Direction HALO communicate
2175  if ( .not. prc_twod ) then
2176  ! From SE
2177  if ( prc_has_s .AND. prc_has_e ) then
2178  tagc = 0
2179  do j = 1, js-1
2180  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2181  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2182  ireq = ireq + 1
2183  tagc = tagc + 1
2184  enddo
2185  else if ( prc_has_s ) then
2186  tagc = 0
2187  do j = 1, js-1
2188  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2189  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2190  ireq = ireq + 1
2191  tagc = tagc + 1
2192  enddo
2193  else if ( prc_has_e ) then
2194  tagc = 0
2195  do j = 1, js-1
2196  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2197  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2198  ireq = ireq + 1
2199  tagc = tagc + 1
2200  enddo
2201  endif
2202  ! From SW
2203  if ( prc_has_s .AND. prc_has_w ) then
2204  tagc = 10
2205  do j = 1, js-1
2206  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2207  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2208  ireq = ireq + 1
2209  tagc = tagc + 1
2210  enddo
2211  else if ( prc_has_s ) then
2212  tagc = 10
2213  do j = 1, js-1
2214  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2215  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2216  ireq = ireq + 1
2217  tagc = tagc + 1
2218  enddo
2219  else if ( prc_has_w ) then
2220  tagc = 10
2221  do j = 1, js-1
2222  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2223  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2224  ireq = ireq + 1
2225  tagc = tagc + 1
2226  enddo
2227  endif
2228  ! From NE
2229  if ( prc_has_n .AND. prc_has_e ) then
2230  tagc = 20
2231  do j = je+1, ja
2232  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2233  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2234  ireq = ireq + 1
2235  tagc = tagc + 1
2236  enddo
2237  else if ( prc_has_n ) then
2238  tagc = 20
2239  do j = je+1, ja
2240  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2241  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2242  ireq = ireq + 1
2243  tagc = tagc + 1
2244  enddo
2245  else if ( prc_has_e ) then
2246  tagc = 20
2247  do j = je+1, ja
2248  call mpi_recv_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2249  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2250  ireq = ireq + 1
2251  tagc = tagc + 1
2252  enddo
2253  endif
2254  ! From NW
2255  if ( prc_has_n .AND. prc_has_w ) then
2256  tagc = 30
2257  do j = je+1, ja
2258  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2259  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2260  ireq = ireq + 1
2261  tagc = tagc + 1
2262  enddo
2263  else if ( prc_has_n ) then
2264  tagc = 30
2265  do j = je+1, ja
2266  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2267  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2268  ireq = ireq + 1
2269  tagc = tagc + 1
2270  enddo
2271  else if ( prc_has_w ) then
2272  tagc = 30
2273  do j = je+1, ja
2274  call mpi_recv_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2275  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2276  ireq = ireq + 1
2277  tagc = tagc + 1
2278  enddo
2279  endif
2280 #ifdef _OPENACC
2281  ptr => ginfo(gid)%recvpack_WE2P(:,:,seqid)
2282  !$acc host_data use_device(ptr)
2283 #endif
2284  ! From E
2285  if ( prc_has_e ) then
2286  tagc = 60
2287 #ifdef _OPENACC
2288  call mpi_recv_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2289 #else
2290  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2291 #endif
2292  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2293  ireq = ireq + 1
2294  endif
2295  ! From W
2296  if ( prc_has_w ) then
2297  tagc = 70
2298 #ifdef _OPENACC
2299  call mpi_recv_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2300 #else
2301  call mpi_recv_init( ginfo(gid)%recvpack_WE2P(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2302 #endif
2303  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2304  ireq = ireq + 1
2305  endif
2306  !$acc end host_data
2307  end if
2308  ! From S
2309  if ( prc_has_s ) then
2310  tagc = 40
2311  do j = 1, js-1
2312  call mpi_recv_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2313  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2314  ireq = ireq + 1
2315  tagc = tagc + 1
2316  enddo
2317  endif
2318  ! From N
2319  if ( prc_has_n ) then
2320  tagc = 50
2321  do j = je+1, ja
2322  call mpi_recv_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2323  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2324  ireq = ireq + 1
2325  tagc = tagc + 1
2326  enddo
2327  endif
2328 
2329  !--- To 8-Direction HALO communicate
2330  ! To N HALO
2331  if ( prc_has_n ) then
2332  tagc = 40
2333  do j = je-jhalo+1, je
2334  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2335  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2336  ireq = ireq + 1
2337  tagc = tagc + 1
2338  enddo
2339  endif
2340  ! To S HALO
2341  if ( prc_has_s ) then
2342  tagc = 50
2343  do j = js, js+jhalo-1
2344  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2345  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2346  ireq = ireq + 1
2347  tagc = tagc + 1
2348  enddo
2349  endif
2350  if ( .not. prc_twod ) then
2351 #ifdef _OPENACC
2352  ptr => ginfo(gid)%sendpack_P2WE(:,:,seqid)
2353  !$acc host_data use_device(ptr)
2354 #endif
2355  ! To W HALO
2356  if ( prc_has_w ) then
2357  tagc = 60
2358 #ifdef _OPENACC
2359  call mpi_send_init( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2360 #else
2361  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,1,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2362 #endif
2363  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2364  ireq = ireq + 1
2365  endif
2366  ! To E HALO
2367  if ( prc_has_e ) then
2368  tagc = 70
2369 #ifdef _OPENACC
2370  call mpi_send_init( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2371 #else
2372  call mpi_send_init( ginfo(gid)%sendpack_P2WE(:,2,seqid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2373 #endif
2374  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2375  ireq = ireq + 1
2376  endif
2377  !$acc end host_data
2378  ! To NW HALO
2379  if ( prc_has_n .AND. prc_has_w ) then
2380  tagc = 0
2381  do j = je-jhalo+1, je
2382  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2383  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2384  ireq = ireq + 1
2385  tagc = tagc + 1
2386  enddo
2387  else if ( prc_has_n ) then
2388  tagc = 10
2389  do j = je-jhalo+1, je
2390  call mpi_send_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2391  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2392  ireq = ireq + 1
2393  tagc = tagc + 1
2394  enddo
2395  else if ( prc_has_w ) then
2396  tagc = 20
2397  do j = je+1, ja
2398  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2399  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2400  ireq = ireq + 1
2401  tagc = tagc + 1
2402  enddo
2403  endif
2404  ! To NE HALO
2405  if ( prc_has_n .AND. prc_has_e ) then
2406  tagc = 10
2407  do j = je-jhalo+1, je
2408  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2409  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2410  ireq = ireq + 1
2411  tagc = tagc + 1
2412  enddo
2413  else if ( prc_has_n ) then
2414  tagc = 0
2415  do j = je-jhalo+1, je
2416  call mpi_send_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2417  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2418  ireq = ireq + 1
2419  tagc = tagc + 1
2420  enddo
2421  else if ( prc_has_e ) then
2422  tagc = 30
2423  do j = je+1, ja
2424  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2425  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2426  ireq = ireq + 1
2427  tagc = tagc + 1
2428  enddo
2429  endif
2430  ! To SW HALO
2431  if ( prc_has_s .AND. prc_has_w ) then
2432  tagc = 20
2433  do j = js, js+jhalo-1
2434  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2435  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2436  ireq = ireq + 1
2437  tagc = tagc + 1
2438  enddo
2439  else if ( prc_has_s ) then
2440  tagc = 30
2441  do j = js, js+jhalo-1
2442  call mpi_send_init( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2443  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2444  ireq = ireq + 1
2445  tagc = tagc + 1
2446  enddo
2447  else if ( prc_has_w ) then
2448  tagc = 0
2449  do j = 1, js-1
2450  call mpi_send_init( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2451  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2452  ireq = ireq + 1
2453  tagc = tagc + 1
2454  enddo
2455  endif
2456  ! To SE HALO
2457  if ( prc_has_s .AND. prc_has_e ) then
2458  tagc = 30
2459  do j = js, js+jhalo-1
2460  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2461  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2462  ireq = ireq + 1
2463  tagc = tagc + 1
2464  enddo
2465  else if ( prc_has_s ) then
2466  tagc = 20
2467  do j = js, js+jhalo-1
2468  call mpi_send_init( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2469  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2470  ireq = ireq + 1
2471  tagc = tagc + 1
2472  enddo
2473  else if ( prc_has_e ) then
2474  tagc = 10
2475  do j = 1, js-1
2476  call mpi_send_init( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2477  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%preq_list(ireq,vid), ierr )
2478  ireq = ireq + 1
2479  tagc = tagc + 1
2480  enddo
2481  endif
2482  end if
2483 
2484  endif
2485 
2486  ginfo(gid)%preq_cnt(vid) = ireq - 1
2487 
2488  ! to finish initial processes of MPI
2489  nreq = ginfo(gid)%preq_cnt(vid)
2490  do i = 1, 32
2491  call mpi_testall( nreq, ginfo(gid)%preq_list(1:nreq,vid), &
2492  flag, mpi_statuses_ignore, ierr )
2493  enddo
2494 
2495  !$acc end host_data
2496 
2497  return

References scale_prc_cartesc::prc_twod.

Referenced by comm_vars8_init().

Here is the caller graph for this function:

◆ vars_3d_mpi()

subroutine scale_comm_cartesc::vars_3d_mpi ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)
Parameters
[in,out]varatmospheric 3D variable to communication
[in]gidgrid ID
[in]vidrequest ID

Definition at line 2500 of file scale_comm_cartesC.F90.

2501  use scale_prc, only: &
2502  prc_abort
2503  use scale_prc_cartesc, only: &
2504  prc_twod
2505  implicit none
2506 
2507  real(RP), intent(inout) :: var(:,:,:)
2508  integer, intent(in) :: gid
2509  integer, intent(in) :: vid
2510 
2511 
2512  integer :: ireq, tag
2513 
2514  integer :: KA
2515  integer :: IA, IS, IE
2516  integer :: JA, JS, JE
2517  integer :: IHALO, JHALO
2518 
2519  integer :: ierr
2520 #ifdef _OPENACC
2521  real(RP), pointer :: ptr(:,:)
2522  logical :: flag_device
2523 #endif
2524  !---------------------------------------------------------------------------
2525 
2526  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
2527  ireq = 1
2528 
2529  ka = ginfo(gid)%KA
2530  ia = ginfo(gid)%IA
2531  is = ginfo(gid)%IS
2532  ie = ginfo(gid)%IE
2533  ja = ginfo(gid)%JA
2534  js = ginfo(gid)%JS
2535  je = ginfo(gid)%JE
2536  ihalo = ginfo(gid)%IHALO
2537  jhalo = ginfo(gid)%JHALO
2538 
2539 #ifdef DEBUG
2540  if ( ginfo(gid)%use_packbuf(vid) ) then
2541  log_error("vars_3D_mpi",*) 'packing buffer is already used', vid
2542  call prc_abort
2543  end if
2544  ginfo(gid)%use_packbuf(vid) = .true.
2545 #endif
2546 
2547 #ifdef _OPENACC
2548  flag_device = acc_is_present(var)
2549 #endif
2550 
2551  !$acc host_data use_device(var) if(flag_device)
2552 
2553  !--- From 4-Direction HALO communicate
2554  ! From S
2555  if ( prc_has_s ) then
2556  call mpi_irecv( var(:,:,1:js-1), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2557  prc_next(prc_s), tag+1, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2558  ireq = ireq + 1
2559  endif
2560  ! From N
2561  if ( prc_has_n ) then
2562  call mpi_irecv( var(:,:,je+1:ja), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2563  prc_next(prc_n), tag+2, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2564  ireq = ireq + 1
2565  endif
2566  if ( .not. prc_twod ) then
2567 #ifdef _OPENACC
2568  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
2569  !$acc host_data use_device(ptr) if(flag_device)
2570 #endif
2571  ! From E
2572  if ( prc_has_e ) then
2573 #ifdef _OPENACC
2574  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2575 #else
2576  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2577 #endif
2578  prc_next(prc_e), tag+3, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2579  ireq = ireq + 1
2580  endif
2581  ! From W
2582  if ( prc_has_w ) then
2583 #ifdef _OPENACC
2584  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2585 #else
2586  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2587 #endif
2588  prc_next(prc_w), tag+4, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2589  ireq = ireq + 1
2590  endif
2591  !$acc end host_data
2592  end if
2593 
2594  !$acc end host_data
2595 
2596  !--- To 4-Direction HALO communicate
2597  if ( .not. prc_twod ) then
2598  call packwe_3d( ka, ia, is, ie, ja, js, je, &
2599  ihalo, &
2600  var, gid, vid)
2601  end if
2602 
2603  !$acc host_data use_device(var) if(flag_device)
2604 
2605  ! To N HALO
2606  if ( prc_has_n ) then
2607  call mpi_isend( var(:,:,je-jhalo+1:je), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2608  prc_next(prc_n), tag+1, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2609  ireq = ireq + 1
2610  endif
2611  ! To S HALO
2612  if ( prc_has_s ) then
2613  call mpi_isend( var(:,:,js:js+jhalo-1), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2614  prc_next(prc_s), tag+2, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2615  ireq = ireq + 1
2616  endif
2617 
2618  !$acc end host_data
2619 
2620  if ( .not. prc_twod ) then
2621 #ifdef _OPENACC
2622  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
2623  !$acc wait
2624  !$acc host_data use_device(ptr) if(flag_device)
2625 #endif
2626  ! To W HALO
2627  if ( prc_has_w ) then
2628 #ifdef _OPENACC
2629  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2630 #else
2631  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2632 #endif
2633  prc_next(prc_w), tag+3, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2634  ireq = ireq + 1
2635  endif
2636  ! To E HALO
2637  if ( prc_has_e ) then
2638 #ifdef _OPENACC
2639  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2640 #else
2641  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2642 #endif
2643  prc_next(prc_e), tag+4, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2644  ireq = ireq + 1
2645  endif
2646 
2647  !$acc end host_data
2648  end if
2649 
2650  ginfo(gid)%req_cnt(vid) = ireq - 1
2651 
2652  return

References packwe_3d(), scale_prc::prc_abort(), and scale_prc_cartesc::prc_twod.

Referenced by comm_vars_3d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ vars_3d_mpi_onesided()

subroutine scale_comm_cartesc::vars_3d_mpi_onesided ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)
Parameters
[in,out]varatmospheric 3D variable to communication
[in]gidgrid ID
[in]vidrequest ID

Definition at line 2655 of file scale_comm_cartesC.F90.

2656  use scale_prc_cartesc, only: &
2657  prc_twod
2658  implicit none
2659 
2660  real(RP), intent(inout) :: var(:,:,:)
2661  integer, intent(in) :: gid
2662  integer, intent(in) :: vid
2663 
2664  integer :: KA
2665  integer :: IA, IS, IE
2666  integer :: JA, JS, JE
2667  integer :: IHALO, JHALO
2668 
2669  integer(kind=MPI_ADDRESS_KIND) :: disp
2670 
2671  integer :: ierr
2672 #ifdef _OPENACC
2673  real(RP), pointer :: ptr(:,:)
2674 #endif
2675  !---------------------------------------------------------------------------
2676 
2677  ka = ginfo(gid)%KA
2678  ia = ginfo(gid)%IA
2679  is = ginfo(gid)%IS
2680  ie = ginfo(gid)%IE
2681  ja = ginfo(gid)%JA
2682  js = ginfo(gid)%JS
2683  je = ginfo(gid)%JE
2684  ihalo = ginfo(gid)%IHALO
2685  jhalo = ginfo(gid)%JHALO
2686 
2687  !$acc data copyin(var)
2688 
2689  call mpi_win_start( group_packwe, 0, ginfo(gid)%win_packWE(vid), ierr )
2690  call mpi_win_start( group_packns, 0, ginfo(gid)%win_packNS(vid), ierr )
2691 
2692  !--- To 4-Direction HALO communicate
2693  if ( .not. prc_twod ) then
2694  call packwe_3d( ka, ia, is, ie, ja, js, je, &
2695  ihalo, &
2696  var, gid, vid)
2697  end if
2698 
2699  !$acc host_data use_device(var)
2700 
2701  ! To N HALO
2702  if ( prc_has_n ) then
2703  disp = 0
2704  call mpi_put( var(:,:,je-jhalo+1:je), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2705  prc_next(prc_n), disp, ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2706  ginfo(gid)%win_packNS(vid), ierr )
2707  endif
2708  ! To S HALO
2709  if ( prc_has_s ) then
2710  disp = ka * ia * jhalo
2711  call mpi_put( var(:,:,js:js+jhalo-1), ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2712  prc_next(prc_s), disp, ginfo(gid)%size2D_NS4*ka, comm_datatype_t, &
2713  ginfo(gid)%win_packNS(vid), ierr )
2714  endif
2715 
2716  !$acc end host_data
2717 
2718  if ( .not. prc_twod ) then
2719 #ifdef _OPENACC
2720  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
2721  !$acc wait
2722  !$acc host_data use_device(ptr)
2723 #endif
2724 
2725  ! To W HALO
2726  if ( prc_has_w ) then
2727  disp = 1
2728 #ifdef _OPENACC
2729  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2730 #else
2731  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2732 #endif
2733  prc_next(prc_w), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2734  ginfo(gid)%win_packWE(vid), ierr )
2735  endif
2736  ! To E HALO
2737  if ( prc_has_e ) then
2738  disp = 0
2739 #ifdef _OPENACC
2740  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2741 #else
2742  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2743 #endif
2744  prc_next(prc_e), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2745  ginfo(gid)%win_packWE(vid), ierr )
2746  endif
2747 
2748  !$acc end host_data
2749  end if
2750 
2751  call mpi_win_complete( ginfo(gid)%win_packWE(vid), ierr )
2752  call mpi_win_complete( ginfo(gid)%win_packNS(vid), ierr )
2753 
2754  !$acc end data
2755 
2756  return

References packwe_3d(), and scale_prc_cartesc::prc_twod.

Referenced by comm_vars_3d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ vars8_3d_mpi()

subroutine scale_comm_cartesc::vars8_3d_mpi ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 2759 of file scale_comm_cartesC.F90.

2760  use scale_prc, only: &
2761  prc_abort
2762  use scale_prc_cartesc, only: &
2763  prc_twod
2764  implicit none
2765 
2766  real(RP), intent(inout) :: var(:,:,:)
2767  integer, intent(in) :: gid
2768  integer, intent(in) :: vid
2769 
2770  integer :: ireq, tag, tagc
2771 
2772  integer :: KA
2773  integer :: IA, IS, IE
2774  integer :: JA, JS, JE
2775  integer :: IHALO, JHALO
2776 
2777  integer :: ierr
2778  integer :: j
2779 #ifdef _OPENACC
2780  real(RP), pointer :: ptr(:,:)
2781  logical :: flag_device
2782 #endif
2783  !---------------------------------------------------------------------------
2784 
2785  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
2786  tag = vid * 100
2787  ireq = 1
2788 
2789  ka = ginfo(gid)%KA
2790  ia = ginfo(gid)%IA
2791  is = ginfo(gid)%IS
2792  ie = ginfo(gid)%IE
2793  ja = ginfo(gid)%JA
2794  js = ginfo(gid)%JS
2795  je = ginfo(gid)%JE
2796  ihalo = ginfo(gid)%IHALO
2797  jhalo = ginfo(gid)%JHALO
2798 
2799 #ifdef DEBUG
2800  if ( ginfo(gid)%use_packbuf(vid) ) then
2801  log_error("vars8_3D_mpi",*) 'packing buffer is already used', vid
2802  call prc_abort
2803  end if
2804  ginfo(gid)%use_packbuf(vid) = .true.
2805 #endif
2806 
2807 #ifdef _OPENACC
2808  flag_device = acc_is_present(var)
2809 #endif
2810 
2811  if ( comm_isallperiodic ) then ! periodic condition
2812 
2813  !$acc host_data use_device(var) if(flag_device)
2814 
2815  !--- From 8-Direction HALO communicate
2816  if ( .not. prc_twod ) then
2817  ! From SE
2818  tagc = 0
2819  do j = 1, js-1
2820  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2821  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2822  ireq = ireq + 1
2823  tagc = tagc + 1
2824  enddo
2825  ! From SW
2826  tagc = 10
2827  do j = 1, js-1
2828  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2829  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2830  ireq = ireq + 1
2831  tagc = tagc + 1
2832  enddo
2833  ! From NE
2834  tagc = 20
2835  do j = je+1, ja
2836  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2837  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2838  ireq = ireq + 1
2839  tagc = tagc + 1
2840  enddo
2841  ! From NW
2842  tagc = 30
2843  do j = je+1, ja
2844  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2845  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2846  ireq = ireq + 1
2847  tagc = tagc + 1
2848  enddo
2849 #ifdef _OPENACC
2850  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
2851  !$acc host_data use_device(ptr) if(flag_device)
2852 #endif
2853  ! From E
2854  tagc = 60
2855 #ifdef _OPENACC
2856  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2857 #else
2858  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2859 #endif
2860  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2861  ireq = ireq + 1
2862  ! From W
2863  tagc = 70
2864 #ifdef _OPENACC
2865  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2866 #else
2867  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2868 #endif
2869  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2870  ireq = ireq + 1
2871  !$acc end host_data
2872  end if
2873  ! From S
2874  tagc = 40
2875  do j = 1, js-1
2876  call mpi_irecv( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2877  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2878  ireq = ireq + 1
2879  tagc = tagc + 1
2880  enddo
2881  ! From N
2882  tagc = 50
2883  do j = je+1, ja
2884  call mpi_irecv( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2885  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2886  ireq = ireq + 1
2887  tagc = tagc + 1
2888  enddo
2889 
2890  !--- To 8-Direction HALO communicate
2891  ! To N HALO
2892  tagc = 40
2893  do j = je-jhalo+1, je
2894  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2895  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2896  ireq = ireq + 1
2897  tagc = tagc + 1
2898  enddo
2899  ! To S HALO
2900  tagc = 50
2901  do j = js, js+jhalo-1
2902  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
2903  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2904  ireq = ireq + 1
2905  tagc = tagc + 1
2906  enddo
2907 
2908  !$acc end host_data
2909 
2910  if ( .not. prc_twod ) then
2911 
2912  call packwe_3d( ka, ia, is, ie, ja, js, je, &
2913  ihalo, &
2914  var, gid, vid)
2915 
2916  !$acc host_data use_device(var) if(flag_device)
2917 
2918  ! To NW HALO
2919  tagc = 0
2920  do j = je-jhalo+1, je
2921  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2922  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2923  ireq = ireq + 1
2924  tagc = tagc + 1
2925  enddo
2926  ! To NE HALO
2927  tagc = 10
2928  do j = je-jhalo+1, je
2929  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2930  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2931  ireq = ireq + 1
2932  tagc = tagc + 1
2933  enddo
2934  ! To SW HALO
2935  tagc = 20
2936  do j = js, js+jhalo-1
2937  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2938  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2939  ireq = ireq + 1
2940  tagc = tagc + 1
2941  enddo
2942  ! To SE HALO
2943  tagc = 30
2944  do j = js, js+jhalo-1
2945  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2946  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2947  ireq = ireq + 1
2948  tagc = tagc + 1
2949  enddo
2950 
2951  !$acc end host_data
2952 
2953 #ifdef _OPENACC
2954  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
2955  !$acc wait
2956  !$acc host_data use_device(ptr) if(flag_device)
2957 #endif
2958  ! To W HALO
2959  tagc = 60
2960 #ifdef _OPENACC
2961  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2962 #else
2963  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2964 #endif
2965  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2966  ireq = ireq + 1
2967  ! To E HALO
2968  tagc = 70
2969 #ifdef _OPENACC
2970  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2971 #else
2972  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
2973 #endif
2974  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2975  !$acc end host_data
2976  ireq = ireq + 1
2977 
2978  end if
2979 
2980  else ! non-periodic condition
2981 
2982  !$acc host_data use_device(var) if(flag_device)
2983 
2984  !--- From 8-Direction HALO communicate
2985  if ( .not. prc_twod ) then
2986  ! From SE
2987  if ( prc_has_s .AND. prc_has_e ) then
2988  tagc = 0
2989  do j = 1, js-1
2990  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2991  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
2992  ireq = ireq + 1
2993  tagc = tagc + 1
2994  enddo
2995  else if ( prc_has_s ) then
2996  tagc = 0
2997  do j = 1, js-1
2998  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
2999  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3000  ireq = ireq + 1
3001  tagc = tagc + 1
3002  enddo
3003  else if ( prc_has_e ) then
3004  tagc = 0
3005  do j = 1, js-1
3006  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3007  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3008  ireq = ireq + 1
3009  tagc = tagc + 1
3010  enddo
3011  endif
3012  ! From SW
3013  if ( prc_has_s .AND. prc_has_w ) then
3014  tagc = 10
3015  do j = 1, js-1
3016  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3017  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3018  ireq = ireq + 1
3019  tagc = tagc + 1
3020  enddo
3021  else if ( prc_has_s ) then
3022  tagc = 10
3023  do j = 1, js-1
3024  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3025  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3026  ireq = ireq + 1
3027  tagc = tagc + 1
3028  enddo
3029  else if ( prc_has_w ) then
3030  tagc = 10
3031  do j = 1, js-1
3032  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3033  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3034  ireq = ireq + 1
3035  tagc = tagc + 1
3036  enddo
3037  endif
3038  ! From NE
3039  if ( prc_has_n .AND. prc_has_e ) then
3040  tagc = 20
3041  do j = je+1, ja
3042  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3043  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3044  ireq = ireq + 1
3045  tagc = tagc + 1
3046  enddo
3047  else if ( prc_has_n ) then
3048  tagc = 20
3049  do j = je+1, ja
3050  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3051  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3052  ireq = ireq + 1
3053  tagc = tagc + 1
3054  enddo
3055  else if ( prc_has_e ) then
3056  tagc = 20
3057  do j = je+1, ja
3058  call mpi_irecv( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3059  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3060  ireq = ireq + 1
3061  tagc = tagc + 1
3062  enddo
3063  endif
3064  ! From NW
3065  if ( prc_has_n .AND. prc_has_w ) then
3066  tagc = 30
3067  do j = je+1, ja
3068  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3069  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3070  ireq = ireq + 1
3071  tagc = tagc + 1
3072  enddo
3073  else if ( prc_has_n ) then
3074  tagc = 30
3075  do j = je+1, ja
3076  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3077  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3078  ireq = ireq + 1
3079  tagc = tagc + 1
3080  enddo
3081  else if ( prc_has_w ) then
3082  tagc = 30
3083  do j = je+1, ja
3084  call mpi_irecv( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3085  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3086  ireq = ireq + 1
3087  tagc = tagc + 1
3088  enddo
3089  endif
3090 #ifdef _OPENACC
3091  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
3092  !$acc host_data use_device(ptr) if(flag_device)
3093 #endif
3094  ! From E
3095  if ( prc_has_e ) then
3096  tagc = 60
3097 #ifdef _OPENACC
3098  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3099 #else
3100  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3101 #endif
3102  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3103  ireq = ireq + 1
3104  endif
3105  ! From W
3106  if ( prc_has_w ) then
3107  tagc = 70
3108 #ifdef _OPENACC
3109  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3110 #else
3111  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3112 #endif
3113  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3114  ireq = ireq + 1
3115  endif
3116  !$acc end host_data
3117  end if
3118  ! From S
3119  if ( prc_has_s ) then
3120  tagc = 40
3121  do j = 1, js-1
3122  call mpi_irecv( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3123  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3124  ireq = ireq + 1
3125  tagc = tagc + 1
3126  enddo
3127  endif
3128  ! From N
3129  if ( prc_has_n ) then
3130  tagc = 50
3131  do j = je+1, ja
3132  call mpi_irecv( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3133  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3134  ireq = ireq + 1
3135  tagc = tagc + 1
3136  enddo
3137  endif
3138 
3139  !--- To 8-Direction HALO communicate
3140  ! To N HALO
3141  if ( prc_has_n ) then
3142  tagc = 40
3143  do j = je-jhalo+1, je
3144  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_NS8*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  endif
3150  ! To S HALO
3151  if ( prc_has_s ) then
3152  tagc = 50
3153  do j = js, js+jhalo-1
3154  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3155  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3156  ireq = ireq + 1
3157  tagc = tagc + 1
3158  enddo
3159  endif
3160 
3161  !$acc end host_data
3162 
3163  if ( .not. prc_twod ) then
3164 
3165  call packwe_3d( ka, ia, is, ie, ja, js, je, &
3166  ihalo, &
3167  var, gid, vid)
3168 
3169  !$acc host_data use_device(var) if(flag_device)
3170 
3171  ! To NW HALO
3172  if ( prc_has_n .AND. prc_has_w ) then
3173  tagc = 0
3174  do j = je-jhalo+1, je
3175  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3176  prc_next(prc_nw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3177  ireq = ireq + 1
3178  tagc = tagc + 1
3179  enddo
3180  else if ( prc_has_n ) then
3181  tagc = 10
3182  do j = je-jhalo+1, je
3183  call mpi_isend( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3184  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3185  ireq = ireq + 1
3186  tagc = tagc + 1
3187  enddo
3188  else if ( prc_has_w ) then
3189  tagc = 20
3190  do j = je+1, ja
3191  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3192  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3193  ireq = ireq + 1
3194  tagc = tagc + 1
3195  enddo
3196  endif
3197  ! To NE HALO
3198  if ( prc_has_n .AND. prc_has_e ) then
3199  tagc = 10
3200  do j = je-jhalo+1, je
3201  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3202  prc_next(prc_ne), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3203  ireq = ireq + 1
3204  tagc = tagc + 1
3205  enddo
3206  else if ( prc_has_n ) then
3207  tagc = 0
3208  do j = je-jhalo+1, je
3209  call mpi_isend( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3210  prc_next(prc_n), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3211  ireq = ireq + 1
3212  tagc = tagc + 1
3213  enddo
3214  else if ( prc_has_e ) then
3215  tagc = 30
3216  do j = je+1, ja
3217  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3218  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3219  ireq = ireq + 1
3220  tagc = tagc + 1
3221  enddo
3222  endif
3223  ! To SW HALO
3224  if ( prc_has_s .AND. prc_has_w ) then
3225  tagc = 20
3226  do j = js, js+jhalo-1
3227  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3228  prc_next(prc_sw), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3229  ireq = ireq + 1
3230  tagc = tagc + 1
3231  enddo
3232  else if ( prc_has_s ) then
3233  tagc = 30
3234  do j = js, js+jhalo-1
3235  call mpi_isend( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3236  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3237  ireq = ireq + 1
3238  tagc = tagc + 1
3239  enddo
3240  else if ( prc_has_w ) then
3241  tagc = 0
3242  do j = 1, js-1
3243  call mpi_isend( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3244  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3245  ireq = ireq + 1
3246  tagc = tagc + 1
3247  enddo
3248  endif
3249  ! To SE HALO
3250  if ( prc_has_s .AND. prc_has_e ) then
3251  tagc = 30
3252  do j = js, js+jhalo-1
3253  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3254  prc_next(prc_se), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3255  ireq = ireq + 1
3256  tagc = tagc + 1
3257  enddo
3258  else if ( prc_has_s ) then
3259  tagc = 20
3260  do j = js, js+jhalo-1
3261  call mpi_isend( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3262  prc_next(prc_s), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3263  ireq = ireq + 1
3264  tagc = tagc + 1
3265  enddo
3266  else if ( prc_has_e ) then
3267  tagc = 10
3268  do j = 1, js-1
3269  call mpi_isend( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3270  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3271  ireq = ireq + 1
3272  tagc = tagc + 1
3273  enddo
3274  endif
3275 
3276  !$acc end host_data
3277 
3278 #ifdef _OPENACC
3279  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
3280  !$acc wait
3281  !$acc host_data use_device(ptr) if(flag_device)
3282 #endif
3283 
3284  ! To W HALO
3285  if ( prc_has_w ) then
3286  tagc = 60
3287 #ifdef _OPENACC
3288  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3289 #else
3290  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3291 #endif
3292  prc_next(prc_w), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3293  ireq = ireq + 1
3294  endif
3295  ! To E HALO
3296  if ( prc_has_e ) then
3297  tagc = 70
3298 #ifdef _OPENACC
3299  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3300 #else
3301  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3302 #endif
3303  prc_next(prc_e), tag+tagc, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3304  ireq = ireq + 1
3305  endif
3306  !$acc end host_data
3307 
3308  end if
3309 
3310  endif
3311 
3312  ginfo(gid)%req_cnt(vid) = ireq - 1
3313 
3314  return

References packwe_3d(), scale_prc::prc_abort(), and scale_prc_cartesc::prc_twod.

Referenced by comm_vars8_3d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ vars8_3d_mpi_onesided()

subroutine scale_comm_cartesc::vars8_3d_mpi_onesided ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 3317 of file scale_comm_cartesC.F90.

3318  use scale_prc_cartesc, only: &
3319  prc_twod
3320  implicit none
3321 
3322  real(RP), intent(inout) :: var(:,:,:)
3323  integer, intent(in) :: gid
3324  integer, intent(in) :: vid
3325 
3326  integer :: KA
3327  integer :: IA, IS, IE
3328  integer :: JA, JS, JE
3329  integer :: IHALO, JHALO
3330 
3331  integer(kind=MPI_ADDRESS_KIND) :: disp
3332 
3333  integer :: ierr
3334  integer :: j
3335 #ifdef _OPENACC
3336  real(RP), pointer :: ptr(:,:)
3337 #endif
3338  !---------------------------------------------------------------------------
3339 
3340  ka = ginfo(gid)%KA
3341  ia = ginfo(gid)%IA
3342  is = ginfo(gid)%IS
3343  ie = ginfo(gid)%IE
3344  ja = ginfo(gid)%JA
3345  js = ginfo(gid)%JS
3346  je = ginfo(gid)%JE
3347  ihalo = ginfo(gid)%IHALO
3348  jhalo = ginfo(gid)%JHALO
3349 
3350  !$acc data copyin(var)
3351  call mpi_win_start( group_packwe, 0, ginfo(gid)%win_packWE(vid), ierr )
3352  call mpi_win_start( group_packns, 0, ginfo(gid)%win_packNS(vid), ierr )
3353 
3354  if ( comm_isallperiodic ) then ! periodic condition
3355 
3356  !$acc host_data use_device(var)
3357 
3358  !--- To 8-Direction HALO communicate
3359  ! To N HALO
3360  do j = je-jhalo+1, je
3361  disp = ka * ( ihalo + ia * ( j - je+jhalo-1 ) )
3362  call mpi_put( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3363  prc_next(prc_n), disp, ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3364  ginfo(gid)%win_packNS(vid), ierr )
3365  enddo
3366  ! To S HALO
3367  do j = js, js+jhalo-1
3368  disp = ka * ( ihalo + ia * ( j - js + jhalo ) )
3369  call mpi_put( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3370  prc_next(prc_s), disp, ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3371  ginfo(gid)%win_packNS(vid), ierr )
3372  enddo
3373 
3374  !$acc end host_data
3375 
3376  if ( .not. prc_twod ) then
3377 
3378  call packwe_3d( ka, ia, is, ie, ja, js, je, &
3379  ihalo, &
3380  var, gid, vid)
3381 
3382  !$acc host_data use_device(var)
3383  ! To NW HALO
3384  do j = je-jhalo+1, je
3385  disp = ka * ( ie + ia * ( j - je+jhalo-1 ) )
3386  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3387  prc_next(prc_nw), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3388  ginfo(gid)%win_packNS(vid), ierr )
3389  enddo
3390  ! To NE HALO
3391  do j = je-jhalo+1, je
3392  disp = ka * ( ia * ( j - je+jhalo-1 ) )
3393  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3394  prc_next(prc_ne), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3395  ginfo(gid)%win_packNS(vid), ierr )
3396  enddo
3397  ! To SW HALO
3398  do j = js, js+jhalo-1
3399  disp = ka * ( ie + ia * ( j - js + jhalo ) )
3400  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3401  prc_next(prc_sw), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3402  ginfo(gid)%win_packNS(vid), ierr )
3403  enddo
3404  ! To SE HALO
3405  do j = js, js+jhalo-1
3406  disp = ka * ( ia * ( j - js + jhalo ) )
3407  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3408  prc_next(prc_se), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3409  ginfo(gid)%win_packNS(vid), ierr )
3410  enddo
3411 
3412  !$acc end host_data
3413 
3414 #ifdef _OPENACC
3415  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
3416  !$acc wait
3417  !$acc host_data use_device(ptr)
3418 #endif
3419  ! To W HALO
3420  disp = 1
3421 #ifdef _OPENACC
3422  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3423 #else
3424  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3425 #endif
3426  prc_next(prc_w), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3427  ginfo(gid)%win_packWE(vid), ierr )
3428  ! To E HALO
3429  disp = 0
3430 #ifdef _OPENACC
3431  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3432 #else
3433  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3434 #endif
3435  prc_next(prc_e), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3436  ginfo(gid)%win_packWE(vid), ierr )
3437  !$acc end host_data
3438 
3439  end if
3440 
3441  else ! non-periodic condition
3442 
3443  !$acc host_data use_device(var)
3444 
3445  !--- To 8-Direction HALO communicate
3446  ! To N HALO
3447  if ( prc_has_n ) then
3448  do j = je-jhalo+1, je
3449  disp = ka * ( ihalo + ia * ( j - je+jhalo-1 ) )
3450  call mpi_put( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3451  prc_next(prc_n), disp, ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3452  ginfo(gid)%win_packNS(vid), ierr )
3453  enddo
3454  endif
3455  ! To S HALO
3456  if ( prc_has_s ) then
3457  do j = js, js+jhalo-1
3458  disp = ka * ( ihalo + ia * ( j - js + jhalo ) )
3459  call mpi_put( var(1,is,j), ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3460  prc_next(prc_s), disp, ginfo(gid)%size2D_NS8*ka, comm_datatype_t, &
3461  ginfo(gid)%win_packNS(vid), ierr )
3462  enddo
3463  endif
3464 
3465  !$acc end host_data
3466 
3467  if ( .not. prc_twod ) then
3468 
3469  call packwe_3d( ka, ia, is, ie, ja, js, je, &
3470  ihalo, &
3471  var, gid, vid)
3472 
3473  !$acc host_data use_device(var)
3474 
3475  ! To NW HALO
3476  if ( prc_has_n .AND. prc_has_w ) then
3477  do j = je-jhalo+1, je
3478  disp = ka * ( ie + ia * ( j - je+jhalo-1 ) )
3479  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3480  prc_next(prc_nw), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3481  ginfo(gid)%win_packNS(vid), ierr )
3482  enddo
3483  else if ( prc_has_n ) then
3484  do j = je-jhalo+1, je
3485  disp = ka * ( ia * ( j - je+jhalo-1 ) )
3486  call mpi_put( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3487  prc_next(prc_n), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3488  ginfo(gid)%win_packNS(vid), ierr )
3489  enddo
3490  else if ( prc_has_w ) then
3491  do j = je+1, ja
3492  disp = ka * ( ie + ia * ( j - je-1 + jhalo ) )
3493  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3494  prc_next(prc_w), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3495  ginfo(gid)%win_packNS(vid), ierr )
3496  enddo
3497  endif
3498  ! To NE HALO
3499  if ( prc_has_n .AND. prc_has_e ) then
3500  do j = je-jhalo+1, je
3501  disp = ka * ( ia * ( j - je+jhalo-1 ) )
3502  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3503  prc_next(prc_ne), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3504  ginfo(gid)%win_packNS(vid), ierr )
3505  enddo
3506  else if ( prc_has_n ) then
3507  do j = je-jhalo+1, je
3508  disp = ka * ( ie + ia * ( j - je+jhalo-1 ) )
3509  call mpi_put( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3510  prc_next(prc_n), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3511  ginfo(gid)%win_packNS(vid), ierr )
3512  enddo
3513  else if ( prc_has_e ) then
3514  do j = je+1, ja
3515  disp = ka * ia * ( j - je-1 + jhalo )
3516  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3517  prc_next(prc_e), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3518  ginfo(gid)%win_packNS(vid), ierr )
3519  enddo
3520  endif
3521  ! To SW HALO
3522  if ( prc_has_s .AND. prc_has_w ) then
3523  do j = js, js+jhalo-1
3524  disp = ka * ( ie + ia * ( j - js + jhalo ) )
3525  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3526  prc_next(prc_sw), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3527  ginfo(gid)%win_packNS(vid), ierr )
3528  enddo
3529  else if ( prc_has_s ) then
3530  do j = js, js+jhalo-1
3531  disp = ka * ( ia * ( j - js + jhalo ) )
3532  call mpi_put( var(1,1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3533  prc_next(prc_s), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3534  ginfo(gid)%win_packNS(vid), ierr )
3535  enddo
3536  else if ( prc_has_w ) then
3537  do j = 1, js-1
3538  disp = ka * ( ie + ia * (j-1) )
3539  call mpi_put( var(1,is,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3540  prc_next(prc_w), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3541  ginfo(gid)%win_packNS(vid), ierr )
3542  enddo
3543  endif
3544  ! To SE HALO
3545  if ( prc_has_s .AND. prc_has_e ) then
3546  do j = js, js+jhalo-1
3547  disp = ka * ( ia * ( j - js + jhalo ) )
3548  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3549  prc_next(prc_se), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3550  ginfo(gid)%win_packNS(vid), ierr )
3551  enddo
3552  else if ( prc_has_s ) then
3553  do j = js, js+jhalo-1
3554  disp = ka * ( ie + ia * ( j - js + jhalo ) )
3555  call mpi_put( var(1,ie+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3556  prc_next(prc_s), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3557  ginfo(gid)%win_packNS(vid), ierr )
3558  enddo
3559  else if ( prc_has_e ) then
3560  do j = 1, js-1
3561  disp = ka * ( ia * ( j - 1 ) )
3562  call mpi_put( var(1,ie-ihalo+1,j), ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3563  prc_next(prc_e), disp, ginfo(gid)%size2D_4C*ka, comm_datatype_t, &
3564  ginfo(gid)%win_packNS(vid), ierr )
3565  enddo
3566  endif
3567 
3568  !$acc end host_data
3569 
3570 #ifdef _OPENACC
3571  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
3572  !$acc wait
3573  !$acc host_data use_device(ptr)
3574 #endif
3575 
3576  ! To W HALO
3577  if ( prc_has_w ) then
3578  disp = 1
3579 #ifdef _OPENACC
3580  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3581 #else
3582  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3583 #endif
3584  prc_next(prc_w), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3585  ginfo(gid)%win_packWE(vid), ierr )
3586  endif
3587  ! To E HALO
3588  if ( prc_has_e ) then
3589  disp = 0
3590 #ifdef _OPENACC
3591  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3592 #else
3593  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3594 #endif
3595  prc_next(prc_e), disp, ginfo(gid)%size2D_WE*ka, comm_datatype_t, &
3596  ginfo(gid)%win_packWE(vid), ierr )
3597  endif
3598  !$acc end host_data
3599 
3600  end if
3601 
3602  endif
3603 
3604  call mpi_win_complete( ginfo(gid)%win_packWE(vid), ierr )
3605  call mpi_win_complete( ginfo(gid)%win_packNS(vid), ierr )
3606 
3607  !$acc end data
3608 
3609  return

References packwe_3d(), and scale_prc_cartesc::prc_twod.

Referenced by comm_vars8_3d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ vars_2d_mpi()

subroutine scale_comm_cartesc::vars_2d_mpi ( real(rp), dimension(:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 3612 of file scale_comm_cartesC.F90.

3613  use scale_prc, only: &
3614  prc_abort
3615  use scale_prc_cartesc, only: &
3616  prc_twod
3617  implicit none
3618 
3619  real(RP), intent(inout) :: var(:,:)
3620  integer, intent(in) :: gid
3621  integer, intent(in) :: vid
3622 
3623  integer :: IA, IS, IE
3624  integer :: JA, JS, JE
3625  integer :: IHALO, JHALO
3626 
3627  integer :: ireq, tag
3628  integer :: ierr
3629 #ifdef _OPENACC
3630  real(RP), pointer :: ptr(:,:)
3631  logical :: flag_device
3632 #endif
3633  !---------------------------------------------------------------------------
3634 
3635  ia = ginfo(gid)%IA
3636  is = ginfo(gid)%IS
3637  ie = ginfo(gid)%IE
3638  ja = ginfo(gid)%JA
3639  js = ginfo(gid)%JS
3640  je = ginfo(gid)%JE
3641  ihalo = ginfo(gid)%IHALO
3642  jhalo = ginfo(gid)%JHALO
3643 
3644  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
3645  ireq = 1
3646 
3647 #ifdef DEBUG
3648  if ( ginfo(gid)%use_packbuf(vid) ) then
3649  log_error("vars_2D_mpi",*) 'packing buffer is already used', vid
3650  call prc_abort
3651  end if
3652  ginfo(gid)%use_packbuf(vid) = .true.
3653 #endif
3654 
3655 #ifdef _OPENACC
3656  flag_device = acc_is_present(var)
3657 #endif
3658 
3659  !$acc host_data use_device(var) if(flag_device)
3660 
3661  !--- From 4-Direction HALO communicate
3662  ! From S
3663  if ( prc_has_s ) then
3664  call mpi_irecv( var(:,1:js-1), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3665  prc_next(prc_s), tag+1, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3666  ireq = ireq + 1
3667  endif
3668  ! From N
3669  if ( prc_has_n ) then
3670  call mpi_irecv( var(:,je+1:ja), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3671  prc_next(prc_n), tag+2, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3672  ireq = ireq + 1
3673  endif
3674 
3675  if ( .not. prc_twod ) then
3676 #ifdef _OPENACC
3677  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
3678  !$acc host_data use_device(ptr) if(flag_device)
3679 #endif
3680  ! From E
3681  if ( prc_has_e ) then
3682 #ifdef _OPENACC
3683  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE, comm_datatype_t, &
3684 #else
3685  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3686 #endif
3687  prc_next(prc_e), tag+3, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3688  ireq = ireq + 1
3689  endif
3690  ! From W
3691  if ( prc_has_w ) then
3692 #ifdef _OPENACC
3693  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE, comm_datatype_t, &
3694 #else
3695  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3696 #endif
3697  prc_next(prc_w), tag+4, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3698  ireq = ireq + 1
3699  endif
3700  !$acc end host_data
3701  end if
3702 
3703  !$acc end host_data
3704 
3705  !--- To 4-Direction HALO communicate
3706  if ( .not. prc_twod ) then
3707 
3708  call packwe_2d( ia, is, ie, ja, js, je, &
3709  ihalo, &
3710  var, gid, vid)
3711 
3712 #ifdef _OPENACC
3713  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
3714  !$acc host_data use_device(ptr) if(flag_device)
3715 #endif
3716 
3717  ! To W HALO communicate
3718  if ( prc_has_w ) then
3719 #ifdef _OPENACC
3720  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE, comm_datatype_t, &
3721 #else
3722  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3723 #endif
3724  prc_next(prc_w), tag+3, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3725  ireq = ireq + 1
3726  endif
3727  ! To E HALO communicate
3728  if ( prc_has_e ) then
3729 #ifdef _OPENACC
3730  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE, comm_datatype_t, &
3731 #else
3732  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3733 #endif
3734  prc_next(prc_e), tag+4, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3735  ireq = ireq + 1
3736  endif
3737 
3738  !$acc end host_data
3739 
3740  end if
3741 
3742  !$acc host_data use_device(var) if(flag_device)
3743 
3744  ! To N HALO communicate
3745  if ( prc_has_n ) then
3746  call mpi_isend( var(:,je-jhalo+1:je), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3747  prc_next(prc_n), tag+1, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3748  ireq = ireq + 1
3749  endif
3750  ! To S HALO communicate
3751  if ( prc_has_s ) then
3752  call mpi_isend( var(:,js:js+jhalo-1), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3753  prc_next(prc_s), tag+2, comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3754  ireq = ireq + 1
3755  endif
3756 
3757  !$acc end host_data
3758 
3759  ginfo(gid)%req_cnt(vid) = ireq - 1
3760 
3761  return

References scale_prc::prc_abort(), and scale_prc_cartesc::prc_twod.

Referenced by comm_vars_2d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ vars_2d_mpi_onesided()

subroutine scale_comm_cartesc::vars_2d_mpi_onesided ( real(rp), dimension(:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 3764 of file scale_comm_cartesC.F90.

3765  use scale_prc_cartesc, only: &
3766  prc_twod
3767  implicit none
3768 
3769  real(RP), intent(inout) :: var(:,:)
3770  integer, intent(in) :: gid
3771  integer, intent(in) :: vid
3772 
3773  integer :: IA, IS, IE
3774  integer :: JA, JS, JE
3775  integer :: IHALO, JHALO
3776 
3777  integer(kind=MPI_ADDRESS_KIND) :: disp
3778 
3779  integer :: ierr
3780 #ifdef _OPENACC
3781  real(RP), pointer :: ptr(:,:)
3782 #endif
3783  !---------------------------------------------------------------------------
3784 
3785  ia = ginfo(gid)%IA
3786  is = ginfo(gid)%IS
3787  ie = ginfo(gid)%IE
3788  ja = ginfo(gid)%JA
3789  js = ginfo(gid)%JS
3790  je = ginfo(gid)%JE
3791  ihalo = ginfo(gid)%IHALO
3792  jhalo = ginfo(gid)%JHALO
3793 
3794  !$acc data copyin(var)
3795 
3796  call mpi_win_start( group_packwe, 0, ginfo(gid)%win_packWE(vid), ierr )
3797  call mpi_win_start( group_packns, 0, ginfo(gid)%win_packNS(vid), ierr )
3798 
3799  !--- To 4-Direction HALO communicate
3800 
3801  if ( .not. prc_twod ) then
3802 
3803  call packwe_2d( ia, is, ie, ja, js, je, &
3804  ihalo, &
3805  var, gid, vid)
3806 
3807 #ifdef _OPENACC
3808  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
3809  !$acc host_data use_device(ptr)
3810 #endif
3811 
3812  ! To W HALO communicate
3813  if ( prc_has_w ) then
3814  disp = 1
3815 #ifdef _OPENACC
3816  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE, comm_datatype_t, &
3817 #else
3818  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3819 #endif
3820  prc_next(prc_w), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
3821  ginfo(gid)%win_packWE(vid), ierr )
3822  endif
3823  ! To E HALO communicate
3824  if ( prc_has_e ) then
3825  disp = 0
3826 #ifdef _OPENACC
3827  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE, comm_datatype_t, &
3828 #else
3829  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
3830 #endif
3831  prc_next(prc_e), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
3832  ginfo(gid)%win_packWE(vid), ierr )
3833  endif
3834 
3835  !$acc end host_data
3836 
3837  end if
3838 
3839  !$acc host_data use_device(var)
3840 
3841  ! To N HALO communicate
3842  if ( prc_has_n ) then
3843  disp = 0
3844  call mpi_put( var(:,je-jhalo+1:je), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3845  prc_next(prc_n), disp, ginfo(gid)%size2D_NS4, comm_datatype_t, &
3846  ginfo(gid)%win_packNS(vid), ierr )
3847  endif
3848  ! To S HALO communicate
3849  if ( prc_has_s ) then
3850  disp = ia * jhalo
3851  call mpi_put( var(:,js:js+jhalo-1), ginfo(gid)%size2D_NS4, comm_datatype_t, &
3852  prc_next(prc_s), disp, ginfo(gid)%size2D_NS4, comm_datatype_t, &
3853  ginfo(gid)%win_packNS(vid), ierr )
3854  endif
3855 
3856  !$acc end host_data
3857 
3858  call mpi_win_complete( ginfo(gid)%win_packWE(vid), ierr )
3859  call mpi_win_complete( ginfo(gid)%win_packNS(vid), ierr )
3860 
3861  !$acc end data
3862 
3863  return

References scale_prc_cartesc::prc_twod.

Referenced by comm_vars_2d().

Here is the caller graph for this function:

◆ vars8_2d_mpi()

subroutine scale_comm_cartesc::vars8_2d_mpi ( real(rp), dimension(:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 3866 of file scale_comm_cartesC.F90.

3867  use scale_prc, only: &
3868  prc_abort
3869  use scale_prc_cartesc, only: &
3870  prc_twod
3871  implicit none
3872 
3873  real(RP), intent(inout) :: var(:,:)
3874  integer, intent(in) :: gid
3875  integer, intent(in) :: vid
3876 
3877  integer :: IA, IS, IE
3878  integer :: JA, JS, JE
3879  integer :: IHALO, JHALO
3880 
3881  integer :: ireq, tag, tagc
3882 
3883  integer :: ierr
3884  integer :: j
3885 #ifdef _OPENACC
3886  real(RP), pointer :: ptr(:,:)
3887  logical :: flag_device
3888 #endif
3889  !---------------------------------------------------------------------------
3890 
3891  ia = ginfo(gid)%IA
3892  is = ginfo(gid)%IS
3893  ie = ginfo(gid)%IE
3894  ja = ginfo(gid)%JA
3895  js = ginfo(gid)%JS
3896  je = ginfo(gid)%JE
3897  ihalo = ginfo(gid)%IHALO
3898  jhalo = ginfo(gid)%JHALO
3899 
3900  tag = ( (gid - 1) * comm_vsize_max + vid ) * 100
3901  ireq = 1
3902 
3903 #ifdef DEBUG
3904  if ( ginfo(gid)%use_packbuf(vid) ) then
3905  log_error("vars8_2D_mpi",*) 'packing buffer is already used', vid
3906  call prc_abort
3907  end if
3908  ginfo(gid)%use_packbuf(vid) = .true.
3909 #endif
3910 
3911 #ifdef _OPENACC
3912  flag_device = acc_is_present(var)
3913 #endif
3914 
3915  if ( comm_isallperiodic ) then
3916  !--- periodic condition
3917  !--- From 8-Direction HALO communicate
3918  !$acc host_data use_device(var) if(flag_device)
3919 
3920  if ( .not. prc_twod ) then
3921  ! From SE
3922  tagc = 0
3923  do j = 1, js-1
3924  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
3925  comm_datatype_t, prc_next(prc_se), tag+tagc, &
3926  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3927  ireq = ireq + 1
3928  tagc = tagc + 1
3929  enddo
3930  ! From SW
3931  tagc = 10
3932  do j = 1, js-1
3933  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
3934  comm_datatype_t, prc_next(prc_sw), tag+tagc, &
3935  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3936  ireq = ireq + 1
3937  tagc = tagc + 1
3938  enddo
3939  ! From NE
3940  tagc = 20
3941  do j = je+1, ja
3942  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
3943  comm_datatype_t, prc_next(prc_ne), tag+tagc, &
3944  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3945  ireq = ireq + 1
3946  tagc = tagc + 1
3947  enddo
3948  ! From NW
3949  tagc = 30
3950  do j = je+1, ja
3951  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
3952  comm_datatype_t, prc_next(prc_nw), tag+tagc, &
3953  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3954  ireq = ireq + 1
3955  tagc = tagc + 1
3956  enddo
3957 #ifdef _OPENACC
3958  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
3959  !$acc host_data use_device(ptr) if(flag_device)
3960 #endif
3961  ! From E
3962 #ifdef _OPENACC
3963  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE, &
3964 #else
3965  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE, &
3966 #endif
3967  comm_datatype_t, prc_next(prc_e), tag+60, &
3968  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3969  ireq = ireq + 1
3970  ! From W
3971 #ifdef _OPENACC
3972  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE, &
3973 #else
3974  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE, &
3975 #endif
3976  comm_datatype_t, prc_next(prc_w), tag+70, &
3977  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3978  ireq = ireq + 1
3979  !$acc end host_data
3980  end if
3981  ! From S
3982  tagc = 40
3983  do j = 1, js-1
3984  call mpi_irecv( var(is,j), ginfo(gid)%size2D_NS8, &
3985  comm_datatype_t, prc_next(prc_s), tag+tagc, &
3986  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3987  ireq = ireq + 1
3988  tagc = tagc + 1
3989  enddo
3990  ! From N
3991  tagc = 50
3992  do j = je+1, ja
3993  call mpi_irecv( var(is,j), ginfo(gid)%size2D_NS8, &
3994  comm_datatype_t, prc_next(prc_n), tag+tagc, &
3995  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
3996  ireq = ireq + 1
3997  tagc = tagc + 1
3998  enddo
3999 
4000 
4001  !--- To 8-Direction HALO communicate
4002 
4003  ! To N HALO communicate
4004  tagc = 40
4005  do j = je-jhalo+1, je
4006  call mpi_isend( var(is,j), ginfo(gid)%size2D_NS8, &
4007  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4008  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4009  ireq = ireq + 1
4010  tagc = tagc + 1
4011  enddo
4012 
4013  ! To S HALO communicate
4014  tagc = 50
4015  do j = js, js+jhalo-1
4016  call mpi_isend( var(is,j), ginfo(gid)%size2D_NS8, &
4017  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4018  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4019  ireq = ireq + 1
4020  tagc = tagc + 1
4021  enddo
4022 
4023  !$acc end host_data
4024 
4025  if ( .not. prc_twod ) then
4026 
4027  call packwe_2d( ia, is, ie, ja, js, je, &
4028  ihalo, &
4029  var, gid, vid)
4030 
4031  !$acc host_data use_device(var) if(flag_device)
4032 #ifdef _OPENACC
4033  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
4034  !$acc host_data use_device(ptr) if(flag_device)
4035 #endif
4036 
4037  ! To W HALO communicate
4038 #ifdef _OPENACC
4039  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE, &
4040 #else
4041  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, &
4042 #endif
4043  comm_datatype_t, prc_next(prc_w), tag+60, &
4044  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4045  ireq = ireq + 1
4046 
4047  ! To E HALO communicate
4048 #ifdef _OPENACC
4049  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE, &
4050 #else
4051  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, &
4052 #endif
4053  comm_datatype_t, prc_next(prc_e), tag+70, &
4054  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4055  ireq = ireq + 1
4056  !$acc end host_data
4057 
4058  ! To NW HALO communicate
4059  tagc = 0
4060  do j = je-jhalo+1, je
4061  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4062  comm_datatype_t, prc_next(prc_nw), tag+tagc, &
4063  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4064  ireq = ireq + 1
4065  tagc = tagc + 1
4066  enddo
4067 
4068  ! To NE HALO communicate
4069  tagc = 10
4070  do j = je-jhalo+1, je
4071  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4072  comm_datatype_t, prc_next(prc_ne), tag+tagc, &
4073  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4074  ireq = ireq + 1
4075  tagc = tagc + 1
4076  enddo
4077 
4078  ! To SW HALO communicate
4079  tagc = 20
4080  do j = js, js+jhalo-1
4081  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4082  comm_datatype_t, prc_next(prc_sw), tag+tagc, &
4083  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4084  ireq = ireq + 1
4085  tagc = tagc + 1
4086  enddo
4087 
4088  ! To SE HALO communicate
4089  tagc = 30
4090  do j = js, js+jhalo-1
4091  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4092  comm_datatype_t, prc_next(prc_se), tag+tagc, &
4093  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4094  ireq = ireq + 1
4095  tagc = tagc + 1
4096  enddo
4097 
4098  !$acc end host_data
4099 
4100  end if
4101 
4102  else
4103  !--- non-periodic condition
4104  !--- From 8-Direction HALO communicate
4105 
4106  !$acc host_data use_device(var) if(flag_device)
4107 
4108  if ( .not. prc_twod ) then
4109  ! From SE
4110  if ( prc_has_s .AND. prc_has_e ) then
4111  tagc = 0
4112  do j = 1, js-1
4113  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4114  comm_datatype_t, prc_next(prc_se), 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_s ) then
4120  tagc = 0
4121  do j = 1, js-1
4122  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4123  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4124  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4125  ireq = ireq + 1
4126  tagc = tagc + 1
4127  enddo
4128  else if ( prc_has_e ) then
4129  tagc = 0
4130  do j = 1, js-1
4131  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4132  comm_datatype_t, prc_next(prc_e), tag+tagc, &
4133  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4134  ireq = ireq + 1
4135  tagc = tagc + 1
4136  enddo
4137  endif
4138 
4139  ! From SW
4140  if ( prc_has_s .AND. prc_has_w ) then
4141  tagc = 10
4142  do j = 1, js-1
4143  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4144  comm_datatype_t, prc_next(prc_sw), 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_s ) then
4150  tagc = 10
4151  do j = 1, js-1
4152  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4153  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4154  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4155  ireq = ireq + 1
4156  tagc = tagc + 1
4157  enddo
4158  else if ( prc_has_w ) then
4159  tagc = 10
4160  do j = 1, js-1
4161  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4162  comm_datatype_t, prc_next(prc_w), tag+tagc, &
4163  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4164  ireq = ireq + 1
4165  tagc = tagc + 1
4166  enddo
4167  endif
4168 
4169  ! From NE
4170  if ( prc_has_n .AND. prc_has_e ) then
4171  tagc = 20
4172  do j = je+1, je+jhalo
4173  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4174  comm_datatype_t, prc_next(prc_ne), 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_n ) then
4180  tagc = 20
4181  do j = je+1, ja
4182  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4183  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4184  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4185  ireq = ireq + 1
4186  tagc = tagc + 1
4187  enddo
4188  else if ( prc_has_e ) then
4189  tagc = 20
4190  do j = je+1, ja
4191  call mpi_irecv( var(ie+1,j), ginfo(gid)%size2D_4C, &
4192  comm_datatype_t, prc_next(prc_e), tag+tagc, &
4193  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4194  ireq = ireq + 1
4195  tagc = tagc + 1
4196  enddo
4197  endif
4198 
4199  ! From NW
4200  if ( prc_has_n .AND. prc_has_w ) then
4201  tagc = 30
4202  do j = je+1, ja
4203  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4204  comm_datatype_t, prc_next(prc_nw), tag+tagc, &
4205  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4206  ireq = ireq + 1
4207  tagc = tagc + 1
4208  enddo
4209  else if ( prc_has_n ) then
4210  tagc = 30
4211  do j = je+1, ja
4212  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4213  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4214  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4215  ireq = ireq + 1
4216  tagc = tagc + 1
4217  enddo
4218  else if ( prc_has_w ) then
4219  tagc = 30
4220  do j = je+1, ja
4221  call mpi_irecv( var(1,j), ginfo(gid)%size2D_4C, &
4222  comm_datatype_t, prc_next(prc_w), tag+tagc, &
4223  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4224  ireq = ireq + 1
4225  tagc = tagc + 1
4226  enddo
4227  endif
4228 
4229 #ifdef _OPENACC
4230  ptr => ginfo(gid)%recvpack_WE2P(:,:,vid)
4231  !$acc host_data use_device(ptr) if(flag_device)
4232 #endif
4233  ! From E
4234  if ( prc_has_e ) then
4235 #ifdef _OPENACC
4236  call mpi_irecv( ptr(:,2), ginfo(gid)%size2D_WE, &
4237 #else
4238  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,2,vid), ginfo(gid)%size2D_WE, &
4239 #endif
4240  comm_datatype_t, prc_next(prc_e), tag+60, &
4241  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4242  ireq = ireq + 1
4243  endif
4244 
4245  ! From W
4246  if ( prc_has_w ) then
4247 #ifdef _OPENACC
4248  call mpi_irecv( ptr(:,1), ginfo(gid)%size2D_WE, &
4249 #else
4250  call mpi_irecv( ginfo(gid)%recvpack_WE2P(:,1,vid), ginfo(gid)%size2D_WE, &
4251 #endif
4252  comm_datatype_t, prc_next(prc_w), tag+70, &
4253  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4254  ireq = ireq + 1
4255  endif
4256  !$acc end host_data
4257 
4258  end if
4259 
4260  ! From S
4261  if ( prc_has_s ) then
4262  tagc = 40
4263  do j = 1, js-1
4264  call mpi_irecv( 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  ! From N
4273  if ( prc_has_n ) then
4274  tagc = 50
4275  do j = je+1, ja
4276  call mpi_irecv( var(is,j), ginfo(gid)%size2D_NS8, &
4277  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4278  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4279  ireq = ireq + 1
4280  tagc = tagc + 1
4281  enddo
4282  endif
4283 
4284 
4285  !! RECEIVE
4286 
4287  ! To N HALO communicate
4288  if ( prc_has_n ) then
4289  tagc = 40
4290  do j = je-jhalo+1, je
4291  call mpi_isend( var(is,j), ginfo(gid)%size2D_NS8, &
4292  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4293  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4294  ireq = ireq + 1
4295  tagc = tagc + 1
4296  enddo
4297  endif
4298 
4299  ! To S HALO communicate
4300  if ( prc_has_s ) then
4301  tagc = 50
4302  do j = js, js+jhalo-1
4303  call mpi_isend( var(is,j), ginfo(gid)%size2D_NS8, &
4304  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4305  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4306  ireq = ireq + 1
4307  tagc = tagc + 1
4308  enddo
4309  endif
4310 
4311  !$acc end host_data
4312 
4313  if ( .not. prc_twod ) then
4314 
4315  call packwe_2d( ia, is, ie, ja, js, je, &
4316  ihalo, &
4317  var, gid, vid)
4318 
4319  !$acc host_data use_device(var) if(flag_device)
4320 #ifdef _OPENACC
4321  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
4322  !$acc host_data use_device(ptr) if(flag_device)
4323 #endif
4324 
4325  ! To W HALO communicate
4326  if ( prc_has_w ) then
4327 #ifdef _OPENACC
4328  call mpi_isend( ptr(:,1), ginfo(gid)%size2D_WE, &
4329 #else
4330  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, &
4331 #endif
4332  comm_datatype_t, prc_next(prc_w), tag+60, &
4333  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4334  ireq = ireq + 1
4335  endif
4336 
4337  ! To E HALO communicate
4338  if ( prc_has_e ) then
4339 #ifdef _OPENACC
4340  call mpi_isend( ptr(:,2), ginfo(gid)%size2D_WE, &
4341 #else
4342  call mpi_isend( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, &
4343 #endif
4344  comm_datatype_t, prc_next(prc_e), tag+70, &
4345  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4346  ireq = ireq + 1
4347  endif
4348  !$acc end host_data
4349 
4350  ! To NW HALO communicate
4351  if ( prc_has_n .AND. prc_has_w ) then
4352  tagc = 0
4353  do j = je-jhalo+1, je
4354  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4355  comm_datatype_t, prc_next(prc_nw), 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_n ) then
4361  tagc = 10
4362  do j = je-jhalo+1, je
4363  call mpi_isend( var(1,j), ginfo(gid)%size2D_4C, &
4364  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4365  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4366  ireq = ireq + 1
4367  tagc = tagc + 1
4368  enddo
4369  else if ( prc_has_w ) then
4370  tagc = 20
4371  do j = je+1, ja
4372  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4373  comm_datatype_t, prc_next(prc_w), tag+tagc, &
4374  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4375  ireq = ireq + 1
4376  tagc = tagc + 1
4377  enddo
4378  endif
4379 
4380  ! To NE HALO communicate
4381  if ( prc_has_n .AND. prc_has_e ) then
4382  tagc = 10
4383  do j = je-jhalo+1, je
4384  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4385  comm_datatype_t, prc_next(prc_ne), 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_n ) then
4391  tagc = 0
4392  do j = je-jhalo+1, je
4393  call mpi_isend( var(ie+1,j), ginfo(gid)%size2D_4C, &
4394  comm_datatype_t, prc_next(prc_n), tag+tagc, &
4395  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4396  ireq = ireq + 1
4397  tagc = tagc + 1
4398  enddo
4399  else if ( prc_has_e ) then
4400  tagc = 30
4401  do j = je+1, ja
4402  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4403  comm_datatype_t, prc_next(prc_e), tag+tagc, &
4404  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4405  ireq = ireq + 1
4406  tagc = tagc + 1
4407  enddo
4408  endif
4409 
4410  ! To SW HALO communicate
4411  if ( prc_has_s .AND. prc_has_w ) then
4412  tagc = 20
4413  do j = js, js+jhalo-1
4414  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4415  comm_datatype_t, prc_next(prc_sw), 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_s ) then
4421  tagc = 30
4422  do j = js, js+jhalo-1
4423  call mpi_isend( var(1,j), ginfo(gid)%size2D_4C, &
4424  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4425  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4426  ireq = ireq + 1
4427  tagc = tagc + 1
4428  enddo
4429  else if ( prc_has_w ) then
4430  tagc = 0
4431  do j = 1, js-1
4432  call mpi_isend( var(is,j), ginfo(gid)%size2D_4C, &
4433  comm_datatype_t, prc_next(prc_w), tag+tagc, &
4434  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4435  ireq = ireq + 1
4436  tagc = tagc + 1
4437  enddo
4438  endif
4439 
4440  ! To SE HALO communicate
4441  if ( prc_has_s .AND. prc_has_e ) then
4442  tagc = 30
4443  do j = js, js+jhalo-1
4444  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4445  comm_datatype_t, prc_next(prc_se), tag+tagc, &
4446  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4447  ireq = ireq + 1
4448  tagc = tagc + 1
4449  enddo
4450  else if ( prc_has_s ) then
4451  tagc = 20
4452  do j = js, js+jhalo-1
4453  call mpi_isend( var(ie+1,j), ginfo(gid)%size2D_4C, &
4454  comm_datatype_t, prc_next(prc_s), tag+tagc, &
4455  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4456  ireq = ireq + 1
4457  tagc = tagc + 1
4458  enddo
4459  else if ( prc_has_e ) then
4460  tagc = 10
4461  do j = 1, js-1
4462  call mpi_isend( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, &
4463  comm_datatype_t, prc_next(prc_e), tag+tagc, &
4464  comm_world_t, ginfo(gid)%req_list(ireq,vid), ierr )
4465  ireq = ireq + 1
4466  tagc = tagc + 1
4467  enddo
4468  endif
4469 
4470  !$acc end host_data
4471 
4472  end if
4473 
4474  endif
4475 
4476  ginfo(gid)%req_cnt(vid) = ireq - 1
4477 
4478  return

References scale_prc::prc_abort(), and scale_prc_cartesc::prc_twod.

Referenced by comm_vars8_2d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ vars8_2d_mpi_onesided()

subroutine scale_comm_cartesc::vars8_2d_mpi_onesided ( real(rp), dimension(:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 4481 of file scale_comm_cartesC.F90.

4482  use scale_prc_cartesc, only: &
4483  prc_twod
4484  implicit none
4485 
4486  real(RP), intent(inout) :: var(:,:)
4487  integer, intent(in) :: gid
4488  integer, intent(in) :: vid
4489 
4490  integer :: IA, IS, IE, IHALO
4491  integer :: JA, JS, JE, JHALO
4492 
4493  integer(kind=MPI_ADDRESS_KIND) :: disp
4494 
4495  integer :: ierr
4496  integer :: j
4497 #ifdef _OPENACC
4498  real(RP), pointer :: ptr(:,:)
4499 #endif
4500  !---------------------------------------------------------------------------
4501 
4502  ia = ginfo(gid)%IA
4503  is = ginfo(gid)%IS
4504  ie = ginfo(gid)%IE
4505  ihalo = ginfo(gid)%IHALO
4506  ja = ginfo(gid)%JA
4507  js = ginfo(gid)%JS
4508  je = ginfo(gid)%JE
4509  jhalo = ginfo(gid)%JHALO
4510 
4511  !$acc data copyin(var)
4512 
4513  call mpi_win_start( group_packwe, 0, ginfo(gid)%win_packWE(vid), ierr )
4514  call mpi_win_start( group_packns, 0, ginfo(gid)%win_packNS(vid), ierr )
4515 
4516  if ( comm_isallperiodic ) then
4517  !--- periodic condition
4518 
4519  !--- To 8-Direction HALO communicate
4520 
4521  !$acc host_data use_device(var)
4522 
4523  ! To N HALO communicate
4524  do j = je-jhalo+1, je
4525  disp = ihalo + ia * ( j - je+jhalo-1 )
4526  call mpi_put( var(is,j), ginfo(gid)%size2D_NS8, comm_datatype_t, &
4527  prc_next(prc_n), disp, ginfo(gid)%size2D_NS8, comm_datatype_t, &
4528  ginfo(gid)%win_packNS(vid), ierr )
4529  enddo
4530  ! To S HALO communicate
4531  do j = js, js+jhalo-1
4532  disp = ihalo + ia * ( j - js + jhalo )
4533  call mpi_put( var(is,j), ginfo(gid)%size2D_NS8, comm_datatype_t, &
4534  prc_next(prc_s), disp, ginfo(gid)%size2D_NS8, comm_datatype_t, &
4535  ginfo(gid)%win_packNS(vid), ierr )
4536  enddo
4537 
4538  !$acc end host_data
4539 
4540  if ( .not. prc_twod ) then
4541 
4542  call packwe_2d( ia, is, ie, ja, js, je, &
4543  ihalo, &
4544  var, gid, vid)
4545 
4546  !$acc host_data use_device(var)
4547 #ifdef _OPENACC
4548  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
4549  !$acc host_data use_device(ptr)
4550 #endif
4551 
4552  ! To W HALO communicate
4553  disp = 1
4554 #ifdef _OPENACC
4555  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE, comm_datatype_t, &
4556 #else
4557  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
4558 #endif
4559  prc_next(prc_w), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
4560  ginfo(gid)%win_packWE(vid), ierr )
4561  ! To E HALO communicate
4562  disp = 0
4563 #ifdef _OPENACC
4564  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE, comm_datatype_t, &
4565 #else
4566  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
4567 #endif
4568  prc_next(prc_e), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
4569  ginfo(gid)%win_packWE(vid), ierr )
4570  !$acc end host_data
4571  ! To NW HALO communicate
4572  do j = je-jhalo+1, je
4573  disp = ie + ia * ( j - je+jhalo-1 )
4574  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4575  prc_next(prc_nw), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4576  ginfo(gid)%win_packNS(vid), ierr )
4577  enddo
4578  ! To NE HALO communicate
4579  do j = je-jhalo+1, je
4580  disp = ia * ( j - je+jhalo-1 )
4581  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4582  prc_next(prc_ne), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4583  ginfo(gid)%win_packNS(vid), ierr )
4584  enddo
4585  ! To SW HALO communicate
4586  do j = js, js+jhalo-1
4587  disp = ie + ia * ( j - js + jhalo )
4588  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4589  prc_next(prc_sw), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4590  ginfo(gid)%win_packNS(vid), ierr )
4591  enddo
4592  ! To SE HALO communicate
4593  do j = js, js+jhalo-1
4594  disp = ia * ( j - js + jhalo )
4595  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4596  prc_next(prc_se), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4597  ginfo(gid)%win_packNS(vid), ierr )
4598  enddo
4599 
4600  !$acc end host_data
4601 
4602  end if
4603  else
4604  !--- non-periodic condition
4605 
4606  !$acc host_data use_device(var)
4607 
4608  ! To N HALO communicate
4609  if ( prc_has_n ) then
4610  do j = je-jhalo+1, je
4611  disp = ihalo + ia * ( j - je+jhalo-1 )
4612  call mpi_put( var(is,j), ginfo(gid)%size2D_NS8, comm_datatype_t, &
4613  prc_next(prc_n), disp, ginfo(gid)%size2D_NS8, comm_datatype_t, &
4614  ginfo(gid)%win_packNS(vid), ierr )
4615  enddo
4616  endif
4617  ! To S HALO communicate
4618  if ( prc_has_s ) then
4619  do j = js, js+jhalo-1
4620  disp = ihalo + ia * ( j - js + jhalo )
4621  call mpi_put( var(is,j), ginfo(gid)%size2D_NS8, comm_datatype_t, &
4622  prc_next(prc_s), disp, ginfo(gid)%size2D_NS8, comm_datatype_t, &
4623  ginfo(gid)%win_packNS(vid), ierr )
4624  enddo
4625  endif
4626 
4627  !$acc end host_data
4628 
4629  if ( .not. prc_twod ) then
4630 
4631  call packwe_2d( ia, is, ie, ja, js, je, &
4632  ihalo, &
4633  var, gid, vid)
4634 
4635  !$acc host_data use_device(var)
4636 #ifdef _OPENACC
4637  ptr => ginfo(gid)%sendpack_P2WE(:,:,vid)
4638  !$acc host_data use_device(ptr)
4639 #endif
4640 
4641  ! To W HALO communicate
4642  if ( prc_has_w ) then
4643  disp = 1
4644 #ifdef _OPENACC
4645  call mpi_put( ptr(:,1), ginfo(gid)%size2D_WE, comm_datatype_t, &
4646 #else
4647  call mpi_put( ginfo(gid)%sendpack_P2WE(:,1,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
4648 #endif
4649  prc_next(prc_w), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
4650  ginfo(gid)%win_packWE(vid), ierr )
4651  endif
4652  ! To E HALO communicate
4653  if ( prc_has_e ) then
4654  disp = 0
4655 #ifdef _OPENACC
4656  call mpi_put( ptr(:,2), ginfo(gid)%size2D_WE, comm_datatype_t, &
4657 #else
4658  call mpi_put( ginfo(gid)%sendpack_P2WE(:,2,vid), ginfo(gid)%size2D_WE, comm_datatype_t, &
4659 #endif
4660  prc_next(prc_e), disp, ginfo(gid)%size2D_WE, comm_datatype_t, &
4661  ginfo(gid)%win_packWE(vid), ierr )
4662  endif
4663  !$acc end host_data
4664  ! To NW HALO communicate
4665  if ( prc_has_n .AND. prc_has_w ) then
4666  do j = je-jhalo+1, je
4667  disp = ie + ia * ( j - je+jhalo-1 )
4668  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4669  prc_next(prc_nw), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4670  ginfo(gid)%win_packNS(vid), ierr )
4671  enddo
4672  else if ( prc_has_n ) then
4673  do j = je-jhalo+1, je
4674  disp = ia * ( j - je+jhalo-1 )
4675  call mpi_put( var(1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4676  prc_next(prc_n), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4677  ginfo(gid)%win_packNS(vid), ierr )
4678  enddo
4679  else if ( prc_has_w ) then
4680  do j = je+1, ja
4681  disp = ie + ia * ( j - je-1 + jhalo )
4682  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4683  prc_next(prc_w), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4684  ginfo(gid)%win_packNS(vid), ierr )
4685  enddo
4686  endif
4687  ! To NE HALO communicate
4688  if ( prc_has_n .AND. prc_has_e ) then
4689  do j = je-jhalo+1, je
4690  disp = ia * ( j - je+jhalo-1 )
4691  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4692  prc_next(prc_ne), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4693  ginfo(gid)%win_packNS(vid), ierr )
4694  enddo
4695  else if ( prc_has_n ) then
4696  do j = je-jhalo+1, je
4697  disp = ie + ia * ( j - je+jhalo-1 )
4698  call mpi_put( var(ie+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4699  prc_next(prc_n), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4700  ginfo(gid)%win_packNS(vid), ierr )
4701  enddo
4702  else if ( prc_has_e ) then
4703  do j = je+1, ja
4704  disp = ia * ( j - je-1 + jhalo )
4705  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4706  prc_next(prc_e), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4707  ginfo(gid)%win_packNS(vid), ierr )
4708  enddo
4709  endif
4710  ! To SW HALO communicate
4711  if ( prc_has_s .AND. prc_has_w ) then
4712  do j = js, js+jhalo-1
4713  disp = ie + ia * ( j - js + jhalo )
4714  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4715  prc_next(prc_sw), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4716  ginfo(gid)%win_packNS(vid), ierr )
4717  enddo
4718  else if ( prc_has_s ) then
4719  do j = js, js+jhalo-1
4720  disp = ia * ( j - js + jhalo )
4721  call mpi_put( var(1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4722  prc_next(prc_s), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4723  ginfo(gid)%win_packNS(vid), ierr )
4724  enddo
4725  else if ( prc_has_w ) then
4726  do j = 1, js-1
4727  disp = ie + ia * ( j - 1 )
4728  call mpi_put( var(is,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4729  prc_next(prc_w), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4730  ginfo(gid)%win_packNS(vid), ierr )
4731  enddo
4732  endif
4733  ! To SE HALO communicate
4734  if ( prc_has_s .AND. prc_has_e ) then
4735  do j = js, js+jhalo-1
4736  disp = ia * ( j - js + jhalo )
4737  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4738  prc_next(prc_se), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4739  ginfo(gid)%win_packNS(vid), ierr )
4740  enddo
4741  else if ( prc_has_s ) then
4742  do j = js, js+jhalo-1
4743  disp = ie + ia * ( j - js + jhalo )
4744  call mpi_put( var(ie+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4745  prc_next(prc_s), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4746  ginfo(gid)%win_packNS(vid), ierr )
4747  enddo
4748  else if ( prc_has_e ) then
4749  do j = 1, js-1
4750  disp = ia * ( j - 1 )
4751  call mpi_put( var(ie-ihalo+1,j), ginfo(gid)%size2D_4C, comm_datatype_t, &
4752  prc_next(prc_e), disp, ginfo(gid)%size2D_4C, comm_datatype_t, &
4753  ginfo(gid)%win_packNS(vid), ierr )
4754  enddo
4755  endif
4756 
4757  !$acc end host_data
4758  end if
4759 
4760  endif
4761 
4762  call mpi_win_complete( ginfo(gid)%win_packWE(vid), ierr )
4763  call mpi_win_complete( ginfo(gid)%win_packNS(vid), ierr )
4764 
4765  !$acc end data
4766 
4767  return

References scale_prc_cartesc::prc_twod.

Referenced by comm_vars8_2d().

Here is the caller graph for this function:

◆ vars_3d_mpi_pc()

subroutine scale_comm_cartesc::vars_3d_mpi_pc ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 4770 of file scale_comm_cartesC.F90.

4771  use scale_prc, only: &
4772  prc_abort
4773  use scale_prc_cartesc, only: &
4774  prc_twod
4775  implicit none
4776  real(RP), intent(inout) :: var(:,:,:)
4777  integer, intent(in) :: gid
4778  integer, intent(in) :: vid
4779 
4780  integer :: KA
4781  integer :: IA, IS, IE
4782  integer :: JA, JS, JE
4783  integer :: IHALO
4784 
4785  integer :: ierr
4786  !---------------------------------------------------------------------------
4787 
4788 #ifdef DEBUG
4789  if ( ginfo(gid)%use_packbuf(ginfo(gid)%packid(vid)) ) then
4790  log_error("vars_3D_mpi_pc",*) 'packing buffer is already used', vid, ginfo(gid)%packid(vid)
4791  call prc_abort
4792  end if
4793  ginfo(gid)%use_packbuf(ginfo(gid)%packid(vid)) = .true.
4794 #endif
4795 
4796 #ifdef _OPENACC
4797  if ( ginfo(gid)%device_alloc(vid+comm_vsize_max) ) then
4798  !$acc update device(var)
4799  end if
4800 #endif
4801 
4802  if ( .not. prc_twod ) then
4803  ka = ginfo(gid)%KA
4804  ia = ginfo(gid)%IA
4805  is = ginfo(gid)%IS
4806  ie = ginfo(gid)%IE
4807  ja = ginfo(gid)%JA
4808  js = ginfo(gid)%JS
4809  je = ginfo(gid)%JE
4810  ihalo = ginfo(gid)%IHALO
4811  call packwe_3d( ka, ia, is, ie, ja, js, je, &
4812  ihalo, &
4813  var, gid, ginfo(gid)%packid(vid))
4814  !$acc wait
4815  end if
4816 
4817  call mpi_startall(ginfo(gid)%preq_cnt(vid), ginfo(gid)%preq_list(1:ginfo(gid)%preq_cnt(vid),vid), ierr)
4818 
4819  return

References packwe_3d(), scale_prc::prc_abort(), and scale_prc_cartesc::prc_twod.

Referenced by comm_vars8_3d(), and comm_vars_3d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ wait_3d_mpi()

subroutine scale_comm_cartesc::wait_3d_mpi ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 4822 of file scale_comm_cartesC.F90.

4823  use scale_prc_cartesc, only: &
4824  prc_twod
4825  implicit none
4826  real(RP), intent(inout) :: var(:,:,:)
4827  integer, intent(in) :: gid
4828  integer, intent(in) :: vid
4829 
4830  integer :: KA
4831  integer :: IA, IS, IE
4832  integer :: JA, JS, JE
4833  integer :: IHALO
4834 
4835  integer :: ierr
4836  !---------------------------------------------------------------------------
4837 
4838  !--- wait packets
4839  call mpi_waitall( ginfo(gid)%req_cnt (vid), &
4840  ginfo(gid)%req_list(1:ginfo(gid)%req_cnt(vid),vid), &
4841  mpi_statuses_ignore, &
4842  ierr )
4843  if ( .not. prc_twod ) then
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  call unpackwe_3d( ka, ia, is, ie, ja, js, je, &
4853  ihalo, &
4854  var, ginfo(gid)%recvpack_WE2P(:,:,vid) )
4855  !$acc wait
4856  end if
4857 
4858 #ifdef DEBUG
4859  ginfo(gid)%use_packbuf(vid) = .false.
4860 #endif
4861 
4862  return

References scale_prc_cartesc::prc_twod.

Referenced by comm_wait_3d().

Here is the caller graph for this function:

◆ wait_3d_mpi_onesided()

subroutine scale_comm_cartesc::wait_3d_mpi_onesided ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 4865 of file scale_comm_cartesC.F90.

4866  use scale_prc_cartesc, only: &
4867  prc_twod
4868  implicit none
4869  real(RP), intent(inout) :: var(:,:,:)
4870  integer, intent(in) :: gid
4871  integer, intent(in) :: vid
4872 
4873  integer :: KA
4874  integer :: IA, IS, IE
4875  integer :: JA, JS, JE
4876  integer :: IHALO, JHALO
4877 
4878  real(RP), pointer :: pack(:)
4879 
4880  integer :: ierr
4881  !---------------------------------------------------------------------------
4882 
4883  ka = ginfo(gid)%KA
4884  ia = ginfo(gid)%IA
4885  is = ginfo(gid)%IS
4886  ie = ginfo(gid)%IE
4887  ja = ginfo(gid)%JA
4888  js = ginfo(gid)%JS
4889  je = ginfo(gid)%JE
4890  ihalo = ginfo(gid)%IHALO
4891  jhalo = ginfo(gid)%JHALO
4892 
4893  call mpi_win_wait( ginfo(gid)%win_packWE(vid), ierr )
4894  if ( .not. prc_twod ) then
4895  call c_f_pointer( ginfo(gid)%recvbuf_WE(vid), pack, (/ginfo(gid)%size2D_WE*ka*2/) )
4896  call unpackwe_3d( ka, ia, is, ie, ja, js, je, &
4897  ihalo, &
4898  var, pack )
4899  end if
4900 
4901  call mpi_win_wait( ginfo(gid)%win_packNS(vid), ierr )
4902  call c_f_pointer( ginfo(gid)%recvbuf_NS(vid), pack, (/ginfo(gid)%size2D_NS4*ka*2/) )
4903  call unpackns_3d( ka, ia, is, ie, ja, js, je, &
4904  jhalo, &
4905  var, pack )
4906 
4907  !$acc wait
4908 
4909  call mpi_win_post( group_packwe, mpi_mode_nostore, ginfo(gid)%win_packWE(vid), ierr )
4910  call mpi_win_post( group_packns, mpi_mode_nostore, ginfo(gid)%win_packNS(vid), ierr )
4911 
4912  return

References scale_prc_cartesc::prc_twod.

Referenced by comm_wait_3d().

Here is the caller graph for this function:

◆ wait_2d_mpi()

subroutine scale_comm_cartesc::wait_2d_mpi ( real(rp), dimension(:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 4915 of file scale_comm_cartesC.F90.

4916  use scale_prc_cartesc, only: &
4917  prc_twod
4918  implicit none
4919  real(RP), intent(inout) :: var(:,:)
4920  integer, intent(in) :: gid
4921  integer, intent(in) :: vid
4922 
4923  integer :: KA
4924  integer :: IA, IS, IE
4925  integer :: JA, JS, JE
4926  integer :: IHALO
4927 
4928  integer :: ierr
4929  !---------------------------------------------------------------------------
4930 
4931  !--- wait packets
4932  call mpi_waitall( ginfo(gid)%req_cnt(vid), &
4933  ginfo(gid)%req_list(1:ginfo(gid)%req_cnt(vid),vid), &
4934  mpi_statuses_ignore, &
4935  ierr )
4936  if ( .not. prc_twod ) then
4937  ka = ginfo(gid)%KA
4938  ia = ginfo(gid)%IA
4939  is = ginfo(gid)%IS
4940  ie = ginfo(gid)%IE
4941  ja = ginfo(gid)%JA
4942  js = ginfo(gid)%JS
4943  je = ginfo(gid)%JE
4944  ihalo = ginfo(gid)%IHALO
4945  call unpackwe_2d( ka, ia, is, ie, ja, js, je, &
4946  ihalo, &
4947  var, ginfo(gid)%recvpack_WE2P(:,:,vid) )
4948  end if
4949 
4950 #ifdef DEBUG
4951  ginfo(gid)%use_packbuf(vid) = .false.
4952 #endif
4953 
4954  return

References scale_prc_cartesc::prc_twod.

Referenced by comm_wait_2d().

Here is the caller graph for this function:

◆ wait_2d_mpi_onesided()

subroutine scale_comm_cartesc::wait_2d_mpi_onesided ( real(rp), dimension(:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 4957 of file scale_comm_cartesC.F90.

4958  use scale_prc_cartesc, only: &
4959  prc_twod
4960  implicit none
4961  real(RP), intent(inout) :: var(:,:)
4962  integer, intent(in) :: gid
4963  integer, intent(in) :: vid
4964 
4965  integer :: KA
4966  integer :: IA, IS, IE
4967  integer :: JA, JS, JE
4968  integer :: IHALO, JHALO
4969 
4970  real(RP), pointer :: pack(:)
4971 
4972  integer :: ierr
4973  !---------------------------------------------------------------------------
4974 
4975  ka = ginfo(gid)%KA
4976  ia = ginfo(gid)%IA
4977  is = ginfo(gid)%IS
4978  ie = ginfo(gid)%IE
4979  ja = ginfo(gid)%JA
4980  js = ginfo(gid)%JS
4981  je = ginfo(gid)%JE
4982  ihalo = ginfo(gid)%IHALO
4983  jhalo = ginfo(gid)%JHALO
4984 
4985  call mpi_win_wait( ginfo(gid)%win_packWE(vid), ierr )
4986  if ( .not. prc_twod ) then
4987  call c_f_pointer( ginfo(gid)%recvbuf_WE(vid), pack, (/ginfo(gid)%size2D_WE*ka*2/) )
4988  call unpackwe_2d( ka, ia, is, ie, ja, js, je, &
4989  ihalo, &
4990  var, pack )
4991  end if
4992 
4993  call mpi_win_wait( ginfo(gid)%win_packNS(vid), ierr )
4994  call c_f_pointer( ginfo(gid)%recvbuf_NS(vid), pack, (/ginfo(gid)%size2D_NS4*ka*2/) )
4995  call unpackns_2d( ia, is, ie, ja, js, je, &
4996  jhalo, &
4997  var, pack )
4998 
4999  call mpi_win_post( group_packwe, mpi_mode_nostore, ginfo(gid)%win_packWE(vid), ierr )
5000  call mpi_win_post( group_packns, mpi_mode_nostore, ginfo(gid)%win_packNS(vid), ierr )
5001 
5002  return

References scale_prc_cartesc::prc_twod.

Referenced by comm_wait_2d().

Here is the caller graph for this function:

◆ wait_3d_mpi_pc()

subroutine scale_comm_cartesc::wait_3d_mpi_pc ( real(rp), dimension(:,:,:), intent(inout)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 5005 of file scale_comm_cartesC.F90.

5006  use scale_prc_cartesc, only: &
5007  prc_twod
5008  implicit none
5009  real(RP), intent(inout) :: var(:,:,:)
5010  integer, intent(in) :: gid
5011  integer, intent(in) :: vid
5012 
5013  integer :: KA
5014  integer :: IA, IS, IE
5015  integer :: JA, JS, JE
5016  integer :: IHALO
5017 
5018  integer :: pid
5019  integer :: ierr
5020 
5021  !--- wait packets
5022  call mpi_waitall( ginfo(gid)%preq_cnt (vid), &
5023  ginfo(gid)%preq_list(1:ginfo(gid)%preq_cnt(vid),vid), &
5024  mpi_statuses_ignore, &
5025  ierr )
5026  if ( .not. prc_twod ) then
5027  ka = ginfo(gid)%KA
5028  ia = ginfo(gid)%IA
5029  is = ginfo(gid)%IS
5030  ie = ginfo(gid)%IE
5031  ja = ginfo(gid)%JA
5032  js = ginfo(gid)%JS
5033  je = ginfo(gid)%JE
5034  ihalo = ginfo(gid)%IHALO
5035  pid = ginfo(gid)%packid(vid)
5036  call unpackwe_3d( ka, ia, is, ie, ja, js, je, &
5037  ihalo, &
5038  var, ginfo(gid)%recvpack_WE2P(:,:,pid) )
5039  !$acc wait
5040  end if
5041 
5042 #ifdef DEBUG
5043  ginfo(gid)%use_packbuf(ginfo(gid)%packid(vid)) = .false.
5044 #endif
5045 
5046 #ifdef _OPENACC
5047  if ( ginfo(gid)%device_alloc(vid+comm_vsize_max) ) then
5048  !$acc update host(var)
5049  end if
5050 #endif
5051 
5052  return

References scale_prc_cartesc::prc_twod.

Referenced by comm_wait_3d().

Here is the caller graph for this function:

◆ packwe_3d()

subroutine scale_comm_cartesc::packwe_3d ( integer, intent(in)  KA,
integer, intent(in)  IA,
integer, intent(in)  IS,
integer, intent(in)  IE,
integer, intent(in)  JA,
integer, intent(in)  JS,
integer, intent(in)  JE,
integer, intent(in)  IHALO,
real(rp), dimension(ka,ia,ja), intent(in)  var,
integer, intent(in)  gid,
integer, intent(in)  vid 
)

Definition at line 5055 of file scale_comm_cartesC.F90.

5058  implicit none
5059  integer, intent(in) :: KA
5060  integer, intent(in) :: IA, IS, IE
5061  integer, intent(in) :: JA, JS, JE
5062  integer, intent(in) :: IHALO
5063  real(RP), intent(in) :: var(KA,IA,JA)
5064  integer, intent(in) :: gid
5065  integer, intent(in) :: vid
5066 
5067  integer :: k, i, j, n
5068 
5069 #ifdef _OPENACC
5070  real(RP), pointer :: ptr(:,:,:)
5071  ptr => ginfo(gid)%sendpack_P2WE
5072 #endif
5073 
5074  !$acc data copyin(var) if(acc_is_present(var))
5075 
5076  call prof_rapstart('COMM_pack', 3)
5077 
5078  if ( prc_has_w ) then
5079  !--- packing packets to West
5080  !$omp parallel do private(i,j,k,n) OMP_SCHEDULE_ collapse(2)
5081  !$acc parallel if(acc_is_present(var)) async
5082  !$acc loop collapse(2) gang
5083  do j = js, je
5084  do i = is, is+ihalo-1
5085  !$acc loop independent vector
5086  do k = 1, ka
5087  n = (j-js) * ka * ihalo &
5088  + (i-is) * ka &
5089  + k
5090 #ifdef _OPENACC
5091  ptr(n,1,vid) = var(k,i,j)
5092 #else
5093  ginfo(gid)%sendpack_P2WE(n,1,vid) = var(k,i,j)
5094 #endif
5095  enddo
5096  enddo
5097  enddo
5098  !$acc end parallel
5099  end if
5100 
5101  if ( prc_has_e ) then
5102  !--- packing packets to East
5103  !$omp parallel do private(i,j,k,n) OMP_SCHEDULE_ collapse(2)
5104  !$acc parallel if(acc_is_present(var)) async
5105  !$acc loop collapse(2) gang
5106  do j = js, je
5107  do i = ie-ihalo+1, ie
5108  !$acc loop independent vector
5109  do k = 1, ka
5110  n = (j-js) * ka * ihalo &
5111  + (i-ie+ihalo-1) * ka &
5112  + k
5113 #ifdef _OPENACC
5114  ptr(n,2,vid) = var(k,i,j)
5115 #else
5116  ginfo(gid)%sendpack_P2WE(n,2,vid) = var(k,i,j)
5117 #endif
5118  enddo
5119  enddo
5120  enddo
5121  !$acc end parallel
5122  end if
5123 
5124  call prof_rapend('COMM_pack', 3)
5125 
5126  !$acc end data
5127 
5128  return

References scale_prc_cartesc::prc_twod.

Referenced by vars8_3d_mpi(), vars8_3d_mpi_onesided(), vars_3d_mpi(), vars_3d_mpi_onesided(), and vars_3d_mpi_pc().

Here is the caller graph for this function:

◆ copy_boundary_2d()

subroutine scale_comm_cartesc::copy_boundary_2d ( real(rp), dimension(:,:), intent(inout)  var,
integer, intent(in)  gid 
)

Definition at line 5758 of file scale_comm_cartesC.F90.

5759  use scale_prc_cartesc, only: &
5760  prc_twod
5761  implicit none
5762 
5763  real(RP), intent(inout) :: var(:,:)
5764  integer, intent(in) :: gid
5765 
5766  integer :: IS, IE, IHALO
5767  integer :: JS, JE, JHALO
5768 
5769  integer :: i, j
5770  !---------------------------------------------------------------------------
5771 
5772  !$acc data copy(var)
5773 
5774  is = ginfo(gid)%IS
5775  ie = ginfo(gid)%IE
5776  ihalo = ginfo(gid)%IHALO
5777  js = ginfo(gid)%JS
5778  je = ginfo(gid)%JE
5779  jhalo = ginfo(gid)%JHALO
5780 
5781  !$omp parallel
5782 
5783  !--- copy inner data to HALO(North)
5784  if( .NOT. prc_has_n ) then
5785  !$acc kernels async
5786  do j = je+1, je+jhalo
5787  !$omp do
5788  do i = is, ie
5789  var(i,j) = var(i,je)
5790  enddo
5791  !$omp end do nowait
5792  enddo
5793  !$acc end kernels
5794  endif
5795 
5796  !--- copy inner data to HALO(South)
5797  if( .NOT. prc_has_s ) then
5798  !$acc kernels async
5799  !$acc loop independent
5800  do j = js-jhalo, js-1
5801  !$omp do
5802  do i = is, ie
5803  var(i,j) = var(i,js)
5804  enddo
5805  !$omp end do nowait
5806  enddo
5807  !$acc end kernels
5808  endif
5809 
5810  if ( .not. prc_twod ) then
5811 
5812  if( .NOT. prc_has_e ) then
5813  !$omp do
5814  !$acc kernels async
5815  do j = js, je
5816  do i = ie+1, ie+ihalo
5817  var(i,j) = var(ie,j)
5818  enddo
5819  enddo
5820  !$acc end kernels
5821  !$omp end do nowait
5822  endif
5823 
5824  if( .NOT. prc_has_w ) then
5825  !$omp do
5826  !$acc kernels async
5827  do j = js, je
5828  !$acc loop independent
5829  do i = is-ihalo, is-1
5830  var(i,j) = var(is,j)
5831  enddo
5832  enddo
5833  !$acc end kernels
5834  !$omp end do nowait
5835  endif
5836 
5837  !--- copy inner data to HALO(NorthWest)
5838  if( .NOT. prc_has_n .AND. .NOT. prc_has_w ) then
5839  !$acc kernels async
5840  do j = je+1, je+jhalo
5841  !$acc loop independent
5842  do i = is-ihalo, is-1
5843  var(i,j) = var(is,je)
5844  enddo
5845  enddo
5846  !$acc end kernels
5847  elseif( .NOT. prc_has_n ) then
5848  !$acc kernels async
5849  do j = je+1, je+jhalo
5850  do i = is-ihalo, is-1
5851  var(i,j) = var(i,je)
5852  enddo
5853  enddo
5854  !$acc end kernels
5855  elseif( .NOT. prc_has_w ) then
5856  !$acc kernels async
5857  do j = je+1, je+jhalo
5858  !$acc loop independent
5859  do i = is-ihalo, is-1
5860  var(i,j) = var(is,j)
5861  enddo
5862  enddo
5863  !$acc end kernels
5864  endif
5865 
5866  !--- copy inner data to HALO(SouthWest)
5867  if( .NOT. prc_has_s .AND. .NOT. prc_has_w ) then
5868  !$acc kernels async
5869  !$acc loop independent
5870  do j = js-jhalo, js-1
5871  !$acc loop independent
5872  do i = is-ihalo, is-1
5873  var(i,j) = var(is,js)
5874  enddo
5875  enddo
5876  !$acc end kernels
5877  elseif( .NOT. prc_has_s ) then
5878  !$acc kernels async
5879  !$acc loop independent
5880  do j = js-jhalo, js-1
5881  do i = is-ihalo, is-1
5882  var(i,j) = var(i,js)
5883  enddo
5884  enddo
5885  !$acc end kernels
5886  elseif( .NOT. prc_has_w ) then
5887  !$acc kernels async
5888  do j = js-jhalo, js-1
5889  !$acc loop independent
5890  do i = is-ihalo, is-1
5891  var(i,j) = var(is,j)
5892  enddo
5893  enddo
5894  !$acc end kernels
5895  endif
5896 
5897  !--- copy inner data to HALO(NorthEast)
5898  if( .NOT. prc_has_n .AND. .NOT. prc_has_e ) then
5899  !$acc kernels async
5900  do j = je+1, je+jhalo
5901  do i = ie+1, ie+ihalo
5902  var(i,j) = var(ie,je)
5903  enddo
5904  enddo
5905  !$acc end kernels
5906  elseif( .NOT. prc_has_n ) then
5907  !$acc kernels async
5908  do j = je+1, je+jhalo
5909  do i = ie+1, ie+ihalo
5910  var(i,j) = var(i,je)
5911  enddo
5912  enddo
5913  !$acc end kernels
5914  elseif( .NOT. prc_has_e ) then
5915  !$acc kernels async
5916  do j = je+1, je+jhalo
5917  do i = ie+1, ie+ihalo
5918  var(i,j) = var(ie,j)
5919  enddo
5920  enddo
5921  !$acc end kernels
5922  endif
5923 
5924  !--- copy inner data to HALO(SouthEast)
5925  if( .NOT. prc_has_s .AND. .NOT. prc_has_e ) then
5926  !$acc kernels async
5927  do j = js-jhalo, js-1
5928  do i = ie+1, ie+ihalo
5929  var(i,j) = var(ie,js)
5930  enddo
5931  enddo
5932  !$acc end kernels
5933  elseif( .NOT. prc_has_s ) then
5934  !$acc kernels async
5935  !$acc loop independent
5936  do j = js-jhalo, js-1
5937  do i = ie+1, ie+ihalo
5938  var(i,j) = var(i,js)
5939  enddo
5940  enddo
5941  !$acc end kernels
5942  elseif( .NOT. prc_has_e ) then
5943  !$acc kernels async
5944  do j = js-jhalo, js-1
5945  do i = ie+1, ie+ihalo
5946  var(i,j) = var(ie,j)
5947  enddo
5948  enddo
5949  !$acc end kernels
5950  endif
5951 
5952  end if
5953 
5954  !$omp end parallel
5955 
5956  !$acc wait
5957 
5958  !$acc end data
5959 
5960  return

References scale_prc_cartesc::prc_twod.

Referenced by comm_wait_2d().

Here is the caller graph for this function:

Variable Documentation

◆ comm_datatype

integer, public scale_comm_cartesc::comm_datatype

datatype of variable

Definition at line 105 of file scale_comm_cartesC.F90.

105  integer, public :: COMM_datatype

Referenced by scale_atmos_phy_lt_sato2019::atmos_phy_lt_electric_field(), scale_atmos_phy_lt_sato2019::atmos_phy_lt_judge_abse(), scale_atmos_phy_lt_sato2019::atmos_phy_lt_neutralization_f2013(), scale_atmos_phy_lt_sato2019::atmos_phy_lt_neutralization_mg2001(), scale_atmos_phy_lt_sato2019::atmos_phy_lt_sato2019_adjustment(), scale_atmos_phy_lt_sato2019::atmos_phy_lt_solve_bicgstab(), scale_comm_cartesc_nest::comm_cartesc_nest_domain_shape(), scale_comm_cartesc_nest::comm_cartesc_nest_intercomm_nestdown_3d(), scale_comm_cartesc_nest::comm_cartesc_nest_issuer_of_receive_3d(), comm_setup(), scale_dft::dft_g2s(), mod_realinput::realinput_surface(), scale_statistics::statistics_detail_2d(), scale_statistics::statistics_detail_3d(), scale_statistics::statistics_horizontal_max_2d(), scale_statistics::statistics_horizontal_max_3d(), scale_statistics::statistics_horizontal_min_2d(), and scale_statistics::statistics_horizontal_min_3d().

◆ comm_world

integer, public scale_comm_cartesc::comm_world

communication world ID

Definition at line 106 of file scale_comm_cartesC.F90.

106  integer, public :: COMM_world

Referenced by scale_atmos_phy_lt_sato2019::atmos_phy_lt_electric_field(), scale_atmos_phy_lt_sato2019::atmos_phy_lt_judge_abse(), scale_atmos_phy_lt_sato2019::atmos_phy_lt_neutralization_f2013(), scale_atmos_phy_lt_sato2019::atmos_phy_lt_neutralization_mg2001(), scale_atmos_phy_lt_sato2019::atmos_phy_lt_sato2019_adjustment(), scale_atmos_phy_lt_sato2019::atmos_phy_lt_solve_bicgstab(), scale_comm_cartesc_nest::comm_cartesc_nest_domain_shape(), comm_setup(), mod_realinput::realinput_surface(), and scale_atmos_dyn_tstep_short_fvm_hivi::solve_bicgstab().

Generated by doxygen 1.9.1