From e0f36900b47a9f44e5da08c4d5fac95c547bba85 Mon Sep 17 00:00:00 2001
From: Philippe WAUTELET <philippe.wautelet@aero.obs-mip.fr>
Date: Fri, 12 Apr 2024 11:21:52 +0200
Subject: [PATCH] Philippe 12/04/2024: GATHERXX_N1: add support for boxes
---
src/LIB/SURCOUCHE/src/mode_gather.f90 | 135 +++++++++++++++++++-------
1 file changed, 98 insertions(+), 37 deletions(-)
diff --git a/src/LIB/SURCOUCHE/src/mode_gather.f90 b/src/LIB/SURCOUCHE/src/mode_gather.f90
index 38064088a..2bc4896ff 100644
--- a/src/LIB/SURCOUCHE/src/mode_gather.f90
+++ b/src/LIB/SURCOUCHE/src/mode_gather.f90
@@ -624,63 +624,124 @@ END IF
END SUBROUTINE GATHERXX_X6
-SUBROUTINE GATHERXX_N1(HDIR,KSEND,KRECV,KROOT,KCOMM)
-USE MODD_IO, ONLY: ISP, ISNPROC
-CHARACTER(LEN=*), INTENT(IN) :: HDIR
-INTEGER,DIMENSION(:),TARGET,INTENT(IN) :: KSEND
-INTEGER,DIMENSION(:),TARGET,INTENT(INOUT):: KRECV
-INTEGER, INTENT(IN) :: KROOT
-INTEGER, INTENT(IN) :: KCOMM
+SUBROUTINE GATHERXX_N1( HDIR, KSEND, KRECV, 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
-INTEGER :: JI
-INTEGER :: IXO,IXE,IYO,IYE
-INTEGER :: IGXO,IGXE,IGYO,IGYE
-INTEGER, DIMENSION(:), POINTER :: ITP
-INTEGER :: IERR
-INTEGER :: IXM, IYM
-!INTEGER, DIMENSION(MPI_STATUS_SIZE):: STATUS
+CHARACTER(LEN=*), INTENT(IN) :: HDIR
+INTEGER, DIMENSION(:), TARGET, INTENT(IN) :: KSEND
+INTEGER, DIMENSION(:), TARGET, INTENT(INOUT) :: KRECV
+INTEGER, INTENT(IN) :: KROOT
+INTEGER, INTENT(IN) :: KCOMM
+INTEGER, OPTIONAL, INTENT(IN) :: KOBOX
+INTEGER, OPTIONAL, INTENT(IN) :: KEBOX
-CALL GET_DOMWRITE_ll(KROOT,'global',IGXO,IGXE,IGYO,IGYE)
+INTEGER :: JI
+INTEGER :: IXO,IXE,IYO,IYE
+INTEGER :: IGXO,IGXE,IGYO,IGYE
+INTEGER :: IXORBOX, IXENDBOX, IYORBOX, IYENDBOX
+INTEGER, DIMENSION(:), POINTER :: IP
+INTEGER :: IERR
+INTEGER :: IXM, IYM
+!INTEGER, DIMENSION(MPI_STATUS_SIZE) :: STATUS
+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
+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
- ITP=>KRECV(IGXO:IGXE)
- IF (JI == KROOT) THEN
- ITP = KSEND(IXO:IXE)
- ELSE
- CALL MPI_RECV(ITP,SIZE(ITP),MNHINT_MPI,JI-1,99+KROOT,KCOMM,MPI_STATUS_IGNORE,IERR)
+ IF ( IXO /= 0 ) THEN ! intersection is not empty
+ IP=>KRECV(IGXO:IGXE)
+ IF (JI == KROOT) THEN
+ IP = KSEND(IXO:IXE)
+ ELSE
+ CALL MPI_RECV(IP,SIZE(IP),MNHINT_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
- ITP=>KRECV(IGYO:IGYE)
- IF (JI==KROOT) THEN
- ITP = KSEND(IYO:IYE)
- ELSE
- CALL MPI_RECV(ITP,SIZE(ITP),MNHINT_MPI,JI-1,99+KROOT,KCOMM,MPI_STATUS_IGNORE,IERR)
+ ELSE IF (HDIR == 'YY' .AND. IXM <= IGXE .AND. IXM >= IGXO) THEN
+ IF ( IYO /= 0 ) THEN ! intersection is not empty
+ IP=>KRECV(IGYO:IGYE)
+ IF (JI==KROOT) THEN
+ IP = KSEND(IYO:IYE)
+ ELSE
+ CALL MPI_RECV(IP,SIZE(IP),MNHINT_MPI,JI-1,99+KROOT,KCOMM,MPI_STATUS_IGNORE,IERR)
+ END IF
END IF
END IF
END DO
-ELSE
+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
- ITP=>KSEND(IXO:IXE)
- CALL MPI_BSEND(ITP,SIZE(ITP),MNHINT_MPI,KROOT-1,99+KROOT,KCOMM,IERR)
+ IF ( IXO /= 0 ) THEN ! intersection is not empty
+ IP=>KSEND(IXO:IXE)
+ NB_REQ = 1
+ CALL MPI_ISEND(IP,SIZE(IP),MNHINT_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),MNHINT_MPI,KROOT-1,99+KROOT,KCOMM,IERR)
+ END IF
ELSE IF (HDIR == 'YY' .AND. IXM <= IGXE .AND. IXM >= IGXO) THEN
- ITP=>KSEND(IYO:IYE)
- CALL MPI_BSEND(ITP,SIZE(ITP),MNHINT_MPI,KROOT-1,99+KROOT,KCOMM,IERR)
+ IF ( IYO /= 0 ) THEN ! intersection is not empty
+ IP=>KSEND(IYO:IYE)
+ NB_REQ = 1
+ CALL MPI_ISEND(IP,SIZE(IP),MNHINT_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),MNHINT_MPI,KROOT-1,99+KROOT,KCOMM,IERR)
+ END IF
END IF
END IF
--
GitLab