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 200 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

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 446 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 626 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 
698  end if
699 
700  deallocate( ginfo(gid)%req_cnt )
701  deallocate( ginfo(gid)%req_list )
702 
703  !$acc exit data delete(ginfo(gid)%recvpack_WE2P)
704  deallocate( ginfo(gid)%recvpack_WE2P )
705 
706  end if
707 
708  !$acc exit data delete(ginfo(gid)%sendpack_P2WE)
709  deallocate( ginfo(gid)%sendpack_P2WE )
710 #ifdef DEBUG
711  deallocate( ginfo(gid)%use_packbuf )
712 #endif
713 
714  end do
715 
716  if ( comm_use_mpi_onesided ) then
717  if ( group_packwe_created ) then
718  call mpi_group_free(group_packwe, ierr)
719  group_packwe_created = .false.
720  end if
721  if ( group_packns_created ) then
722  call mpi_group_free(group_packns, ierr)
723  group_packns_created = .false.
724  end if
725  end if
726 
727 
728  comm_gid = 0
729 
730  initialized = .false.
731 
732  return

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 742 of file scale_comm_cartesC.F90.

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

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 811 of file scale_comm_cartesC.F90.

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

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 876 of file scale_comm_cartesC.F90.

876  use scale_prc, only: &
877  prc_abort
878  implicit none
879 
880  real(RP), intent(inout) :: var(:,:,:)
881 
882  integer, intent(in) :: vid
883 
884  integer, intent(in), optional :: gid
885 
886  integer :: gid_
887  !---------------------------------------------------------------------------
888 
889  gid_ = 1
890  if ( present(gid) ) gid_ = gid
891  if ( gid_ > comm_gid_max ) then
892  log_error("COMM_vars_3D",*) 'gid is invalid', gid_, comm_gid_max
893  call prc_abort
894  end if
895 
896  if ( vid > comm_vsize_max ) then
897  call prof_rapstart('COMM_vars_pers', 2)
898  call vars_3d_mpi_pc(var, gid_, vid-comm_vsize_max)
899  call prof_rapend ('COMM_vars_pers', 2)
900  else
901  call prof_rapstart('COMM_vars', 2)
902  if ( comm_use_mpi_onesided ) then
903  call vars_3d_mpi_onesided(var, gid_, vid)
904  else
905  call vars_3d_mpi(var, gid_, vid)
906  end if
907  call prof_rapend ('COMM_vars', 2)
908  end if
909 
910  return

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 915 of file scale_comm_cartesC.F90.

915  use scale_prc, only: &
916  prc_abort
917  implicit none
918 
919  real(RP), intent(inout) :: var(:,:,:)
920 
921  integer, intent(in) :: vid
922 
923  integer, intent(in), optional :: gid
924 
925  integer :: gid_
926  !---------------------------------------------------------------------------
927 
928  gid_ = 1
929  if ( present(gid) ) gid_ = gid
930  if ( gid_ > comm_gid_max ) then
931  log_error("COMM_vars8_3D",*) 'gid is invalid', gid_, comm_gid_max
932  call prc_abort
933  end if
934 
935  if ( vid > comm_vsize_max ) then
936  call prof_rapstart('COMM_vars_pers', 2)
937  call vars_3d_mpi_pc(var, gid_, vid-comm_vsize_max)
938  call prof_rapend ('COMM_vars_pers', 2)
939  else
940  call prof_rapstart('COMM_vars', 2)
941  if ( comm_use_mpi_onesided ) then
942  call vars8_3d_mpi_onesided(var, gid_, vid)
943  else
944  call vars8_3d_mpi(var, gid_, vid)
945  end if
946  call prof_rapend ('COMM_vars', 2)
947  end if
948 
949  return

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 954 of file scale_comm_cartesC.F90.

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

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 1005 of file scale_comm_cartesC.F90.

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

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 1038 of file scale_comm_cartesC.F90.

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

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 1071 of file scale_comm_cartesC.F90.

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

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.

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

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.

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

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.

1265  use scale_prc, only: &
1266  prc_masterrank
1267  implicit none
1268 
1269  integer, intent(in) :: IA, JA
1270  real(RP), intent(in) :: send(IA,JA)
1271 
1272  real(RP), intent(out) :: recv(:,:,:)
1273 
1274  integer :: sendcounts, recvcounts
1275  integer :: ierr
1276  !---------------------------------------------------------------------------
1277 
1278  sendcounts = ia * ja
1279  recvcounts = ia * ja
1280 
1281  !$acc host_data use_device(send, recv) if(acc_is_present(send))
1282  call mpi_gather( send(:,:), &
1283  sendcounts, &
1284  comm_datatype_t, &
1285  recv(:,:,:), &
1286  recvcounts, &
1287  comm_datatype_t, &
1288  prc_masterrank, &
1289  comm_world_t, &
1290  ierr )
1291  !$acc end host_data
1292 
1293  return

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.

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

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 1336 of file scale_comm_cartesC.F90.

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

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 1362 of file scale_comm_cartesC.F90.

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

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 1391 of file scale_comm_cartesC.F90.

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

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 1421 of file scale_comm_cartesC.F90.

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

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 1454 of file scale_comm_cartesC.F90.

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

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 1484 of file scale_comm_cartesC.F90.

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

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 1517 of file scale_comm_cartesC.F90.

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

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 1547 of file scale_comm_cartesC.F90.

1547  use scale_prc, only: &
1548  prc_masterrank
1549  implicit none
1550 
1551  integer, intent(in) :: KA, IA, JA
1552 
1553  real(DP), intent(inout) :: var(KA,IA,JA)
1554 
1555  integer :: counts
1556  integer :: ierr
1557  !---------------------------------------------------------------------------
1558 
1559  call prof_rapstart('COMM_Bcast', 2)
1560 
1561  counts = ka * ia * ja
1562 
1563  !$acc host_data use_device(var) if(acc_is_present(var))
1564  call mpi_bcast( var(:,:,:), &
1565  counts, &
1566  mpi_double_precision, &
1567  prc_masterrank, &
1568  comm_world_t, &
1569  ierr )
1570  !$acc end host_data
1571 
1572  call prof_rapend('COMM_Bcast', 2)
1573 
1574  return

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 1580 of file scale_comm_cartesC.F90.

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

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 1616 of file scale_comm_cartesC.F90.

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

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 1655 of file scale_comm_cartesC.F90.

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

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 1684 of file scale_comm_cartesC.F90.

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

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 1714 of file scale_comm_cartesC.F90.

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

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 1747 of file scale_comm_cartesC.F90.

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

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 1776 of file scale_comm_cartesC.F90.

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

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 1808 of file scale_comm_cartesC.F90.

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

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 1838 of file scale_comm_cartesC.F90.

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

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 1975 of file scale_comm_cartesC.F90.

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

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 2497 of file scale_comm_cartesC.F90.

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

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 2652 of file scale_comm_cartesC.F90.

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

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 2756 of file scale_comm_cartesC.F90.

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

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 3314 of file scale_comm_cartesC.F90.

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

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 3609 of file scale_comm_cartesC.F90.

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

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 3761 of file scale_comm_cartesC.F90.

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

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 3863 of file scale_comm_cartesC.F90.

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

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 4478 of file scale_comm_cartesC.F90.

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

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 4767 of file scale_comm_cartesC.F90.

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

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 4819 of file scale_comm_cartesC.F90.

4819  use scale_prc_cartesc, only: &
4820  prc_twod
4821  implicit none
4822  real(RP), intent(inout) :: var(:,:,:)
4823  integer, intent(in) :: gid
4824  integer, intent(in) :: vid
4825 
4826  integer :: KA
4827  integer :: IA, IS, IE
4828  integer :: JA, JS, JE
4829  integer :: IHALO
4830 
4831  integer :: ierr
4832  !---------------------------------------------------------------------------
4833 
4834  !--- wait packets
4835  call mpi_waitall( ginfo(gid)%req_cnt (vid), &
4836  ginfo(gid)%req_list(1:ginfo(gid)%req_cnt(vid),vid), &
4837  mpi_statuses_ignore, &
4838  ierr )
4839  if ( .not. prc_twod ) then
4840  ka = ginfo(gid)%KA
4841  ia = ginfo(gid)%IA
4842  is = ginfo(gid)%IS
4843  ie = ginfo(gid)%IE
4844  ja = ginfo(gid)%JA
4845  js = ginfo(gid)%JS
4846  je = ginfo(gid)%JE
4847  ihalo = ginfo(gid)%IHALO
4848  call unpackwe_3d( ka, ia, is, ie, ja, js, je, &
4849  ihalo, &
4850  var, ginfo(gid)%recvpack_WE2P(:,:,vid) )
4851  !$acc wait
4852  end if
4853 
4854 #ifdef DEBUG
4855  ginfo(gid)%use_packbuf(vid) = .false.
4856 #endif
4857 
4858  return

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 4862 of file scale_comm_cartesC.F90.

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

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 4912 of file scale_comm_cartesC.F90.

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

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 4954 of file scale_comm_cartesC.F90.

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

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 5002 of file scale_comm_cartesC.F90.

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

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 5054 of file scale_comm_cartesC.F90.

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

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 5755 of file scale_comm_cartesC.F90.

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

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().

scale_prc::prc_abort
subroutine, public prc_abort
Abort Process.
Definition: scale_prc.F90:350
scale_atmos_grid_cartesc_index::ihalo
integer, public ihalo
Definition: scale_atmos_grid_cartesC_index.F90:44
scale_atmos_grid_cartesc_index::ka
integer, public ka
Definition: scale_atmos_grid_cartesC_index.F90:47
scale_prc::prc_local_comm_world
integer, public prc_local_comm_world
local communicator
Definition: scale_prc.F90:89
scale_prc
module PROCESS
Definition: scale_prc.F90:11
scale_precision::rp
integer, parameter, public rp
Definition: scale_precision.F90:41
scale_atmos_grid_cartesc_index::ie
integer, public ie
end point of inner domain: x, local
Definition: scale_atmos_grid_cartesC_index.F90:54
scale_prc::prc_masterrank
integer, parameter, public prc_masterrank
master process in each communicator
Definition: scale_prc.F90:67
scale_const
module CONSTANT
Definition: scale_const.F90:11
scale_atmos_grid_cartesc_index::ia
integer, public ia
Definition: scale_atmos_grid_cartesC_index.F90:48
scale_prc_cartesc
module process / cartesC
Definition: scale_prc_cartesC.F90:11
scale_atmos_grid_cartesc_index::is
integer, public is
start point of inner domain: x, local
Definition: scale_atmos_grid_cartesC_index.F90:53
scale_atmos_grid_cartesc_index::jhalo
integer, public jhalo
Definition: scale_atmos_grid_cartesC_index.F90:45
scale_atmos_grid_cartesc_index::ja
integer, public ja
Definition: scale_atmos_grid_cartesC_index.F90:49
scale_atmos_grid_cartesc_index::jmax
integer, public jmax
Definition: scale_atmos_grid_cartesC_index.F90:38
scale_atmos_grid_cartesc_index::js
integer, public js
start point of inner domain: y, local
Definition: scale_atmos_grid_cartesC_index.F90:55
scale_const::const_undef
real(rp), public const_undef
Definition: scale_const.F90:43
scale_atmos_grid_cartesc_index::je
integer, public je
end point of inner domain: y, local
Definition: scale_atmos_grid_cartesC_index.F90:56
scale_prc_cartesc::prc_twod
logical, public prc_twod
2D experiment
Definition: scale_prc_cartesC.F90:56
Generated by   doxygen 1.8.17