From ca34693eb8e7d9bec81393060e149f55686de959 Mon Sep 17 00:00:00 2001
From: Philippe WAUTELET <philippe.wautelet@aero.obs-mip.fr>
Date: Fri, 12 Apr 2024 10:48:21 +0200
Subject: [PATCH] Philippe 12/04/2024: GATHERXX_X1: add support for boxes
---
src/LIB/SURCOUCHE/src/mode_gather.f90 | 124 ++++++++++++++++++--------
1 file changed, 88 insertions(+), 36 deletions(-)
diff --git a/src/LIB/SURCOUCHE/src/mode_gather.f90 b/src/LIB/SURCOUCHE/src/mode_gather.f90
index 7307df850..38064088a 100644
--- a/src/LIB/SURCOUCHE/src/mode_gather.f90
+++ b/src/LIB/SURCOUCHE/src/mode_gather.f90
@@ -195,19 +195,24 @@ END SUBROUTINE GATHERALL_L3
!
! Gather des champs XX (ou YY)
!
-SUBROUTINE GATHERXX_X1(HDIR,PSEND,PRECV,KROOT,KCOMM)
-USE MODD_IO, ONLY: ISP, ISNPROC
-USE MODD_VAR_ll, ONLY: MNH_STATUSES_IGNORE
-
-CHARACTER(LEN=*), INTENT(IN) :: HDIR
-REAL,DIMENSION(:),TARGET,INTENT(IN) :: PSEND
-REAL,DIMENSION(:),TARGET,INTENT(INOUT):: PRECV
-INTEGER, INTENT(IN) :: KROOT
-INTEGER, INTENT(IN) :: KCOMM
+SUBROUTINE GATHERXX_X1( HDIR, PSEND, PRECV, KROOT, KCOMM, KOBOX, KEBOX )
+USE MODD_DIM_n, ONLY: NIMAX_ll, NJMAX_ll
+USE MODD_IO, ONLY: ISP, ISNPROC
+USE MODD_PARAMETERS, ONLY: JPHEXT, JPVEXT
+USE MODD_VAR_ll, ONLY: MNH_STATUSES_IGNORE
+
+CHARACTER(LEN=*), INTENT(IN) :: HDIR
+REAL, DIMENSION(:), TARGET, INTENT(IN) :: PSEND
+REAL, DIMENSION(:), TARGET, INTENT(INOUT) :: PRECV
+INTEGER, INTENT(IN) :: KROOT
+INTEGER, INTENT(IN) :: KCOMM
+INTEGER, OPTIONAL, INTENT(IN) :: KOBOX
+INTEGER, OPTIONAL, INTENT(IN) :: KEBOX
INTEGER :: JI
INTEGER :: IXO,IXE,IYO,IYE
INTEGER :: IGXO,IGXE,IGYO,IGYE
+INTEGER :: IXORBOX, IXENDBOX, IYORBOX, IYENDBOX
REAL, DIMENSION(:), POINTER :: XP
INTEGER :: IERR
INTEGER :: IXM, IYM
@@ -215,52 +220,99 @@ INTEGER :: IXM, IYM
INTEGER :: REQ(1)
INTEGER :: NB_REQ
+LOGICAL :: GBOX
+
+GBOX = .FALSE.
+
+IF ( PRESENT(KOBOX) .AND. PRESENT(KEBOX) ) THEN
+ GBOX = .TRUE.
+ IF ( HDIR == 'XX' ) THEN
+ IXORBOX = KOBOX
+ IXENDBOX = KEBOX
+ IYORBOX = 1
+ IYENDBOX = NJMAX_ll + 2 * JPHEXT
+ ELSE IF ( HDIR == 'YY' ) THEN
+ IXORBOX = 1
+ IXENDBOX = NIMAX_ll + 2 * JPHEXT
+ IYORBOX = KOBOX
+ IYENDBOX = KEBOX
+ ELSE
+ !Nothing to do
+ END IF
+END IF
-CALL GET_DOMWRITE_ll(KROOT,'global',IGXO,IGXE,IGYO,IGYE)
+IF ( GBOX ) THEN
+ CALL GET_DOMWRITE_ll( KROOT, 'global', IGXO, IGXE, IGYO, IGYE, &
+ KXORBOX=IXORBOX, KXENDBOX=IXENDBOX, KYORBOX=IYORBOX, KYENDBOX=IYENDBOX )
+ELSE
+ CALL GET_DOMWRITE_ll( KROOT, 'global', IGXO, IGXE, IGYO, IGYE )
+END IF
IXM = (IGXE+IGXO)/2
IYM = (IGYE+IGYO)/2
IF (ISP == KROOT) THEN
! I/O proc case
DO JI=1,ISNPROC
- CALL GET_DOMWRITE_ll(JI,'global',IGXO,IGXE,IGYO,IGYE)
- CALL GET_DOMWRITE_ll(JI,'local',IXO,IXE,IYO,IYE)
-
+ IF ( GBOX ) THEN
+ CALL GET_DOMWRITE_ll( JI, 'global',IGXO, IGXE, IGYO, IGYE, &
+ KXORBOX=IXORBOX, KXENDBOX=IXENDBOX, KYORBOX=IYORBOX, KYENDBOX=IYENDBOX )
+ CALL GET_DOMWRITE_ll( JI, 'local', IXO, IXE, IYO, IYE, &
+ KXORBOX=IXORBOX, KXENDBOX=IXENDBOX, KYORBOX=IYORBOX, KYENDBOX=IYENDBOX )
+ ELSE
+ CALL GET_DOMWRITE_ll( JI, 'global',IGXO, IGXE, IGYO, IGYE )
+ CALL GET_DOMWRITE_ll( JI, 'local', IXO, IXE, IYO, IYE )
+ END IF
+
IF (HDIR == 'XX' .AND. IYM <= IGYE .AND. IYM >= IGYO) THEN
- XP=>PRECV(IGXO:IGXE)
- IF (JI == KROOT) THEN
- XP = PSEND(IXO:IXE)
- ELSE
- CALL MPI_RECV(XP,SIZE(XP),MNHREAL_MPI,JI-1,99+KROOT,KCOMM,MPI_STATUS_IGNORE,IERR)
+ IF ( IXO /= 0 ) THEN ! intersection is not empty
+ XP=>PRECV(IGXO:IGXE)
+ IF (JI == KROOT) THEN
+ XP = PSEND(IXO:IXE)
+ ELSE
+ CALL MPI_RECV(XP,SIZE(XP),MNHREAL_MPI,JI-1,99+KROOT,KCOMM,MPI_STATUS_IGNORE,IERR)
+ END IF
END IF
ELSE IF (HDIR == 'YY' .AND. IXM <= IGXE .AND. IXM >= IGXO) THEN
- XP=>PRECV(IGYO:IGYE)
- IF (JI==KROOT) THEN
- XP = PSEND(IYO:IYE)
- ELSE
- CALL MPI_RECV(XP,SIZE(XP),MNHREAL_MPI,JI-1,99+KROOT,KCOMM,MPI_STATUS_IGNORE,IERR)
+ IF ( IYO /= 0 ) THEN ! intersection is not empty
+ XP=>PRECV(IGYO:IGYE)
+ IF (JI==KROOT) THEN
+ XP = PSEND(IYO:IYE)
+ ELSE
+ CALL MPI_RECV(XP,SIZE(XP),MNHREAL_MPI,JI-1,99+KROOT,KCOMM,MPI_STATUS_IGNORE,IERR)
+ END IF
END IF
END IF
END DO
ELSE
! Other processes
- CALL GET_DOMWRITE_ll(ISP,'global',IGXO,IGXE,IGYO,IGYE)
- CALL GET_DOMWRITE_ll(ISP,'local',IXO,IXE,IYO,IYE)
-
+ IF ( GBOX ) THEN
+ CALL GET_DOMWRITE_ll( ISP, 'global',IGXO, IGXE, IGYO, IGYE, &
+ KXORBOX=IXORBOX, KXENDBOX=IXENDBOX, KYORBOX=IYORBOX, KYENDBOX=IYENDBOX )
+ CALL GET_DOMWRITE_ll( ISP, 'local', IXO, IXE, IYO, IYE, &
+ KXORBOX=IXORBOX, KXENDBOX=IXENDBOX, KYORBOX=IYORBOX, KYENDBOX=IYENDBOX )
+ ELSE
+ CALL GET_DOMWRITE_ll( ISP, 'global',IGXO, IGXE, IGYO, IGYE )
+ CALL GET_DOMWRITE_ll( ISP, 'local', IXO, IXE, IYO, IYE )
+ END IF
+
IF (HDIR == 'XX' .AND. IYM <= IGYE .AND. IYM >= IGYO) THEN
- XP=>PSEND(IXO:IXE)
- NB_REQ = 1
- CALL MPI_ISEND(XP,SIZE(XP),MNHREAL_MPI,KROOT-1,99+KROOT,KCOMM,REQ(NB_REQ),IERR)
- CALL MPI_WAITALL(NB_REQ,REQ,MNH_STATUSES_IGNORE,IERR)
- !CALL MPI_BSEND(XP,SIZE(XP),MNHREAL_MPI,KROOT-1,99+KROOT,KCOMM,IERR)
+ IF ( IXO /= 0 ) THEN ! intersection is not empty
+ XP=>PSEND(IXO:IXE)
+ NB_REQ = 1
+ CALL MPI_ISEND(XP,SIZE(XP),MNHREAL_MPI,KROOT-1,99+KROOT,KCOMM,REQ(NB_REQ),IERR)
+ CALL MPI_WAITALL(NB_REQ,REQ,MNH_STATUSES_IGNORE,IERR)
+ !CALL MPI_BSEND(XP,SIZE(XP),MNHREAL_MPI,KROOT-1,99+KROOT,KCOMM,IERR)
+ END IF
ELSE IF (HDIR == 'YY' .AND. IXM <= IGXE .AND. IXM >= IGXO) THEN
- XP=>PSEND(IYO:IYE)
- NB_REQ = 1
- CALL MPI_ISEND(XP,SIZE(XP),MNHREAL_MPI,KROOT-1,99+KROOT,KCOMM,REQ(NB_REQ),IERR)
- CALL MPI_WAITALL(NB_REQ,REQ,MNH_STATUSES_IGNORE,IERR)
- !CALL MPI_BSEND(XP,SIZE(XP),MNHREAL_MPI,KROOT-1,99+KROOT,KCOMM,IERR)
+ IF ( IYO /= 0 ) THEN ! intersection is not empty
+ XP=>PSEND(IYO:IYE)
+ NB_REQ = 1
+ CALL MPI_ISEND(XP,SIZE(XP),MNHREAL_MPI,KROOT-1,99+KROOT,KCOMM,REQ(NB_REQ),IERR)
+ CALL MPI_WAITALL(NB_REQ,REQ,MNH_STATUSES_IGNORE,IERR)
+ !CALL MPI_BSEND(XP,SIZE(XP),MNHREAL_MPI,KROOT-1,99+KROOT,KCOMM,IERR)
+ END IF
END IF
END IF
--
GitLab