Repository: ecmwf-ifs/ectrans
Pull request #226: Re-phase an optimisation lost after cycle 48
Author: login: AlexandreMary
Labels: name: contributor
Created: 2025-03-12T13:39:00Z | Merged: 2025-03-28T11:58:01Z

Cherry-pick of PR ACCORD-NWP#8 from @RyadElKhatibMF on ACCORD-NWP fork.

Numerical impact: bit-reproducible
Computational impact: Positive or neutral, depending on the configuration.



Diff:
diff --git a/src/etrans/cpu/external/edist_grid.F90 b/src/etrans/cpu/external/edist_grid.F90
index 85d488a32..3f542b5d5 100644
--- a/src/etrans/cpu/external/edist_grid.F90
+++ b/src/etrans/cpu/external/edist_grid.F90
@@ -77,7 +77,7 @@ SUBROUTINE EDIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT)
 INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN)  :: KSORT (:)
 !ifndef INTERFACE
 
-INTEGER(KIND=JPIM) :: IFSEND,J,IUBOUND(3),IPROMA,IGPBLKS
+INTEGER(KIND=JPIM) :: IFSEND,J,IUBOUND(3),IPROMA,IGPBLKS, IFLDS
 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE
 
 !     ------------------------------------------------------------------
@@ -136,7 +136,9 @@ SUBROUTINE EDIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT)
   ENDIF
 ENDIF
 
-CALL DIST_GRID_CTL(PGPG,KFDISTG,IPROMA,KFROM,PGP,KSORT)
+IFLDS=SIZE(PGP,DIM=2)
+
+CALL DIST_GRID_CTL(PGPG,KFDISTG,IPROMA,KFROM,IFLDS,PGP,KSORT)
 IF (LHOOK) CALL DR_HOOK('EDIST_GRID',1,ZHOOK_HANDLE)
 
 !endif INTERFACE
diff --git a/src/trans/cpu/external/dist_grid.F90 b/src/trans/cpu/external/dist_grid.F90
index 736153921..e753defd9 100644
--- a/src/trans/cpu/external/dist_grid.F90
+++ b/src/trans/cpu/external/dist_grid.F90
@@ -76,7 +76,7 @@ SUBROUTINE DIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT)
 
 !ifndef INTERFACE
 
-INTEGER(KIND=JPIM) :: IFSEND,J,IUBOUND(3),IPROMA,IGPBLKS
+INTEGER(KIND=JPIM) :: IFSEND,J,IUBOUND(3),IPROMA,IGPBLKS, IFLDS
 REAL(KIND=JPHOOK)  :: ZHOOK_HANDLE
 
 !     ------------------------------------------------------------------
@@ -135,7 +135,9 @@ SUBROUTINE DIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT)
   ENDIF
 ENDIF
 
-CALL DIST_GRID_CTL(PGPG,KFDISTG,IPROMA,KFROM,PGP,KSORT)
+IFLDS=SIZE(PGP,DIM=2)
+
+CALL DIST_GRID_CTL(PGPG,KFDISTG,IPROMA,KFROM,IFLDS,PGP,KSORT)
 
 IF (LHOOK) CALL DR_HOOK('DIST_GRID',1,ZHOOK_HANDLE)
 !endif INTERFACE
diff --git a/src/trans/cpu/internal/dist_grid_ctl_mod.F90 b/src/trans/cpu/internal/dist_grid_ctl_mod.F90
index 30aeefa20..4ab4bca1f 100644
--- a/src/trans/cpu/internal/dist_grid_ctl_mod.F90
+++ b/src/trans/cpu/internal/dist_grid_ctl_mod.F90
@@ -10,7 +10,7 @@
 
 MODULE DIST_GRID_CTL_MOD
 CONTAINS
-SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
+SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,KFLDS,PGP,KSORT)
 
 !**** *DIST_GRID_CTL* - Distributing global gridpoint array to processors
 
@@ -25,10 +25,11 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
 !     Explicit arguments :
 !     --------------------
 !     PGPG(:,:)   - Global gridpoint array
-!     KFDISTG     - Global number of fields to be distributed
+!     KFDISTG     - Number of fields in this task to be distributed among all tasks
 !     KPROMA      - required blocking factor for gridpoint output
 !     KFROM(:)    - Processor responsible for distributing each field
-!     PGP(:,:,:)  - Local spectral array
+!     KFLDS       - Number of fields in output distributed arrays
+!     PGP(:,:,:)  - Local gridpoint array
 !     KSORT(:)    - Add KSORT
 
 !     Externals.  SET2PE - compute "A and B" set from PE
@@ -42,17 +43,18 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
 !     --------------
 !        Original : 2000-04-01
 !    P.Marguinaud : 2014-10-10
-
+!    R. El khatib 19-Jun-2019 Optimize by overlapping communications with pack/unpack and making less but larger messages.
+!    R. El khatib 13-Jun-2022 Reduce pressure on the stack and/or fix a lost optimization
 !     ------------------------------------------------------------------
 
 USE PARKIND1  ,ONLY : JPIM     ,JPRB
-USE MPL_MODULE  ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT,     &
-     &                  JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD
+USE MPL_MODULE  ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_WAITANY
 
 USE TPM_DISTR       ,ONLY : D, MTAGDISTGP, NPRCIDS, MYPROC, NPROC
 USE TPM_GEOMETRY    ,ONLY : G
 
 USE SET2PE_MOD      ,ONLY : SET2PE
+USE PE2SET_MOD      ,ONLY : PE2SET
 USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS
 USE EQ_REGIONS_MOD  ,ONLY : N_REGIONS, N_REGIONS_NS
 !
@@ -61,27 +63,25 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
 
 ! Declaration of arguments
 
-REAL(KIND=JPRB)    ,OPTIONAL, INTENT(IN)  :: PGPG(:,:)
 INTEGER(KIND=JPIM)          , INTENT(IN)  :: KFDISTG
+REAL(KIND=JPRB)    ,OPTIONAL, INTENT(IN)  :: PGPG(D%NGPTOTG,KFDISTG)
 INTEGER(KIND=JPIM)          , INTENT(IN)  :: KPROMA
-INTEGER(KIND=JPIM)          , INTENT(IN)  :: KFROM(:)
-REAL(KIND=JPRB)             , INTENT(OUT) :: PGP(:,:,:)
+INTEGER(KIND=JPIM)          , INTENT(IN)  :: KFROM(KFDISTG)
+INTEGER(KIND=JPIM)          , INTENT(IN)  :: KFLDS
+REAL(KIND=JPRB)             , INTENT(OUT) :: PGP(KPROMA,KFLDS,(D%NGPTOT-1)/KPROMA+1) 
 INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN), TARGET :: KSORT (:)
 
 ! Declaration of local variables
 
-! SS/2018: Removed stack hogs
 
-!REAL(KIND=JPRB)    :: ZDUM(D%NGPTOTMX) -- not used
-REAL(KIND=JPRB),ALLOCATABLE :: ZBUF(:,:,:)
 REAL(KIND=JPRB),ALLOCATABLE :: ZRCV(:,:) ! (D%NGPTOTMX,KFDISTG)
-INTEGER(KIND=JPIM) :: JFLD,JB,JA,IGLOFF,IGL1,IGL2,IOFF,ILAST,ILOFF
-INTEGER(KIND=JPIM) :: JGL,JLON,ISND,ITAG,J,IRCV
-INTEGER(KIND=JPIM) :: JKGLO,IEND,JROF,IBL,JROC
-INTEGER(KIND=JPIM) :: ISENDREQ(NPROC,KFDISTG),ILEN(NPROC,KFDISTG), IRECVREQ(KFDISTG)
-INTEGER(KIND=JPIM) :: IFROM,IMYFIELDS,IFLD
+REAL(KIND=JPRB),ALLOCATABLE :: ZBUF(:,:,:)
+REAL(KIND=JPRB)    :: ZGP(D%NGPTOT)
+INTEGER(KIND=JPIM) :: JFLD,JB,JA,IGLOFF,IGL1,IGL2,IOFF, JGL,ITO,ITAG,J,IRCV, JROC, ILOCFLD, IGPBLKS
+INTEGER(KIND=JPIM) :: JKGLO,IEND,IBL, IW,IV, IS, IR, JR, INR, IFLDCOUNT, IFLDLOC(KFDISTG)
+INTEGER(KIND=JPIM) :: ISENDREQ(NPROC), IPROC(NPROC), IRCVREQ(NPROC), IOFFPROC(NPROC)
+INTEGER(KIND=JPIM), ALLOCATABLE :: IOFFGP(:), IOFFA(:), ILONA(:)
 INTEGER(KIND=JPIM), POINTER :: ISORT (:)
-LOGICAL :: LLSAME
 
 !     ------------------------------------------------------------------
 
@@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+        !$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+          !$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+          !$OMP END DO
+        ELSE
+          !$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+          !$OMP END DO
+        ENDIF
+        !$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+    !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
       ENDDO
-    ENDIF
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+    ENDDO
+    !$OMP END PARALLEL DO
   ELSE
-    IFLD = 0
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        IFLD = IFLD+1
-        ITAG = MTAGDISTGP+JFLD
-        DO JROC=1,NPROC
-          CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-           &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),&
-           &CDSTRING='DIST_GRID_CTL')
-        ENDDO
-      ENDIF
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      !$OMP PARALLEL PRIVATE(JGL,JKGLO,IEND,IBL)
+      !$OMP DO SCHEDULE(STATIC)
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+      ENDDO
+      !$OMP END DO
+      !$OMP DO SCHEDULE(STATIC)
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+      !$OMP END DO
+      !$OMP END PARALLEL
     ENDDO
   ENDIF
-      
+  CALL GSTATS(1663,1)
 
-! Wait for sends and receives to complete
+ENDIF
 
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 1')
+! Wait for recv to complete and fill
+DO JR=1, IR
+  CALL GSTATS(811,0)
+  CALL MPL_WAITANY(KREQUEST=IRCVREQ(1:IR), KINDEX=INR, CDSTRING='DIST_GRID_CTL: WAIT FOR RECV')
+  CALL GSTATS(811,1)
+  CALL GSTATS(1663,0)
+  IFLDCOUNT=0
+  DO JFLD=1,KFDISTG
+    IF(KFROM(JFLD) == IPROC(INR)) THEN
+      IFLDCOUNT = IFLDCOUNT+1
+      IFLDLOC(IFLDCOUNT)=JFLD
     ENDIF
-    CALL MPL_WAIT(KREQUEST=IRECVREQ(1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 2')
+  ENDDO
+  !$OMP PARALLEL PRIVATE(JFLD,JKGLO,IEND,IBL,ILOCFLD)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+    !$OMP DO SCHEDULE(STATIC)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZRCV(JKGLO:JKGLO+IEND-1,IOFFPROC(INR)+JFLD)
+      ENDDO
+    ENDDO
+    !$OMP END DO
   ELSE
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        CALL MPL_WAIT(KREQUEST=ISENDREQ(:,JFLD), &
-         & CDSTRING='DIST_GRID_CTL: WAIT 3')
-      ENDIF
-      CALL MPL_WAIT(KREQUEST=IRECVREQ(JFLD), &
-         & CDSTRING='DIST_GRID_CTL: WAIT 4')
+    !$OMP DO SCHEDULE(STATIC)
+    DO JKGLO=1,D%NGPTOT,KPROMA
+      DO JFLD=1,IFLDCOUNT
+        ILOCFLD=ISORT(IFLDLOC(JFLD))
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZRCV(JKGLO:JKGLO+IEND-1,IOFFPROC(INR)+JFLD)
+      ENDDO
     ENDDO
+    !$OMP END DO
   ENDIF
+  !$OMP END PARALLEL
+  CALL GSTATS(1663,1)
+ENDDO
 
+! Wait for send to complete
+IF (IS > 0) THEN
+  CALL GSTATS(811,0)
+  CALL MPL_WAIT(KREQUEST=ISENDREQ(1:IS), CDSTRING='DIST_GRID_CTL: WAIT FOR SEND')
   CALL GSTATS(811,1)
-  CALL GSTATS_BARRIER2(791)
-
-  CALL GSTATS(1663,0)
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = ZRCV(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-  CALL GSTATS(1663,1)
-  DEALLOCATE(ZRCV)
-  !Synchronize processors
-  CALL GSTATS(786,0)
-  CALL MPL_BARRIER(CDSTRING='DIST_GRID_CTL:')
-  CALL GSTATS(786,1)
-  IF(ALLOCATED(ZBUF)) DEALLOCATE(ZBUF)
 ENDIF
 
+CALL GSTATS_BARRIER2(791)
+
 IF (.NOT. PRESENT (KSORT)) THEN
   DEALLOCATE (ISORT)
 ENDIF
@@ -274,7 +316,3 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
 
 END SUBROUTINE DIST_GRID_CTL
 END MODULE DIST_GRID_CTL_MOD
-
-
-
-


Reviews:
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:53:02Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:53:30Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:55:04Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:55:38Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:55:53Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:56:09Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:56:32Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:56:52Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:57:11Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:57:22Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:57:48Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:58:09Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:58:26Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:58:45Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:58:56Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:59:07Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:59:19Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:59:28Z
user: login: samhatfield
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-03-19T16:59:38Z
user: login: marsdeno
state: APPROVED
author_association: COLLABORATOR
submitted_at: 2025-03-20T11:37:07Z

Review comments:
diff_hunk: @@ -61,27 +63,25 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
 
 ! Declaration of arguments
 
-REAL(KIND=JPRB)    ,OPTIONAL, INTENT(IN)  :: PGPG(:,:)
 INTEGER(KIND=JPIM)          , INTENT(IN)  :: KFDISTG
+REAL(KIND=JPRB)    ,OPTIONAL, INTENT(IN)  :: PGPG(D%NGPTOTG,KFDISTG)
 INTEGER(KIND=JPIM)          , INTENT(IN)  :: KPROMA
-INTEGER(KIND=JPIM)          , INTENT(IN)  :: KFROM(:)
-REAL(KIND=JPRB)             , INTENT(OUT) :: PGP(:,:,:)
+INTEGER(KIND=JPIM)          , INTENT(IN)  :: KFROM(KFDISTG)
+INTEGER(KIND=JPIM)          , INTENT(IN)  :: KFLDS
+REAL(KIND=JPRB)             , INTENT(OUT) :: PGP(KPROMA,KFLDS,(D%NGPTOT-1)/KPROMA+1) 
 INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN), TARGET :: KSORT (:)
 
 ! Declaration of local variables
 
-! SS/2018: Removed stack hogs
 
-!REAL(KIND=JPRB)    :: ZDUM(D%NGPTOTMX) -- not used
-REAL(KIND=JPRB),ALLOCATABLE :: ZBUF(:,:,:)
 REAL(KIND=JPRB),ALLOCATABLE :: ZRCV(:,:) ! (D%NGPTOTMX,KFDISTG)
-INTEGER(KIND=JPIM) :: JFLD,JB,JA,IGLOFF,IGL1,IGL2,IOFF,ILAST,ILOFF
-INTEGER(KIND=JPIM) :: JGL,JLON,ISND,ITAG,J,IRCV
-INTEGER(KIND=JPIM) :: JKGLO,IEND,JROF,IBL,JROC
-INTEGER(KIND=JPIM) :: ISENDREQ(NPROC,KFDISTG),ILEN(NPROC,KFDISTG), IRECVREQ(KFDISTG)
-INTEGER(KIND=JPIM) :: IFROM,IMYFIELDS,IFLD
+REAL(KIND=JPRB),ALLOCATABLE :: ZBUF(:,:,:)
+REAL(KIND=JPRB)    :: ZGP(D%NGPTOT)
+INTEGER(KIND=JPIM) :: JFLD,JB,JA,IGLOFF,IGL1,IGL2,IOFF,ILAST, JGL,JLON,ITO,ITAG,J,IRCV, JROC, ILOCFLD, IGPBLKS
+INTEGER(KIND=JPIM) :: JKGLO,IEND,JROF,IBL, IW,IV, IS, IR, JR, INR, IFLDCOUNT, IFLDLOC(KFDISTG)
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
INTEGER(KIND=JPIM) :: JFLD,JB,JA,IGLOFF,IGL1,IGL2,IOFF,JGL,ITO,ITAG,J,IRCV, JROC, ILOCFLD, IGPBLKS
INTEGER(KIND=JPIM) :: JKGLO,IEND,IBL, IW,IV, IS, IR, JR, INR, IFLDCOUNT, IFLDLOC(KFDISTG)
```
These variables are unused.
created_at: 2025-03-19T16:53:02Z
author_association: COLLABORATOR
diff_hunk: @@ -42,17 +43,18 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
 !     --------------
 !        Original : 2000-04-01
 !    P.Marguinaud : 2014-10-10
-
+!    R. El khatib 19-Jun-2019 Optimize by overlapping communications with pack/unpack and making less but larger messages.
+!    R. El khatib 13-Jun-2022 Reduce pressure on the stack and/or fix a lost optimization
 !     ------------------------------------------------------------------
 
 USE PARKIND1  ,ONLY : JPIM     ,JPRB
-USE MPL_MODULE  ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT,     &
-     &                  JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD
+USE MPL_MODULE  ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_WAITANY
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
USE MPL_MODULE  ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_WAITANY
```
`MPL_BARRIER` isn't called here, I think.
created_at: 2025-03-19T16:53:29Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
        !$OMP PARALLEL PRIVATE(JFLD,JGL)
```
Indentation for code readability. I realise the previous file didn't indent `!$OMP` directives either, but we're gradually trying to improve the code standards... I'll suggest other places where these can be indented below.
created_at: 2025-03-19T16:55:04Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
          !$OMP DO SCHEDULE(STATIC)
```
created_at: 2025-03-19T16:55:38Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
          !$OMP END DO
```
created_at: 2025-03-19T16:55:53Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
          !$OMP DO SCHEDULE(STATIC)
```
created_at: 2025-03-19T16:56:09Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
          !$OMP DO SCHEDULE(STATIC)
```
created_at: 2025-03-19T16:56:31Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
        !$OMP END PARALLEL
```
created_at: 2025-03-19T16:56:51Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
    !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
```
created_at: 2025-03-19T16:57:10Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
       ENDDO
-    ENDIF
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+    ENDDO
+!$OMP END PARALLEL DO
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
    !$OMP END PARALLEL DO
```
created_at: 2025-03-19T16:57:21Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
       ENDDO
-    ENDIF
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+    ENDDO
+!$OMP END PARALLEL DO
   ELSE
-    IFLD = 0
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        IFLD = IFLD+1
-        ITAG = MTAGDISTGP+JFLD
-        DO JROC=1,NPROC
-          CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-           &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),&
-           &CDSTRING='DIST_GRID_CTL')
-        ENDDO
-      ENDIF
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+!$OMP PARALLEL PRIVATE(JGL,JKGLO,IEND,IBL)
+!$OMP DO SCHEDULE(STATIC) 
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
      !$OMP PARALLEL PRIVATE(JGL,JKGLO,IEND,IBL)
      !$OMP DO SCHEDULE(STATIC) 
```
created_at: 2025-03-19T16:57:48Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
       ENDDO
-    ENDIF
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+    ENDDO
+!$OMP END PARALLEL DO
   ELSE
-    IFLD = 0
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        IFLD = IFLD+1
-        ITAG = MTAGDISTGP+JFLD
-        DO JROC=1,NPROC
-          CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-           &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),&
-           &CDSTRING='DIST_GRID_CTL')
-        ENDDO
-      ENDIF
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+!$OMP PARALLEL PRIVATE(JGL,JKGLO,IEND,IBL)
+!$OMP DO SCHEDULE(STATIC) 
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+      ENDDO
+!$OMP END DO
+!$OMP DO SCHEDULE(STATIC)
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
      !$OMP END DO
      !$OMP DO SCHEDULE(STATIC)
```
created_at: 2025-03-19T16:58:09Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
       ENDDO
-    ENDIF
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+    ENDDO
+!$OMP END PARALLEL DO
   ELSE
-    IFLD = 0
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        IFLD = IFLD+1
-        ITAG = MTAGDISTGP+JFLD
-        DO JROC=1,NPROC
-          CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-           &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),&
-           &CDSTRING='DIST_GRID_CTL')
-        ENDDO
-      ENDIF
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+!$OMP PARALLEL PRIVATE(JGL,JKGLO,IEND,IBL)
+!$OMP DO SCHEDULE(STATIC) 
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+      ENDDO
+!$OMP END DO
+!$OMP DO SCHEDULE(STATIC)
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+!$OMP END DO
+!$OMP END PARALLEL
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
      !$OMP END DO
      !$OMP END PARALLEL
```
created_at: 2025-03-19T16:58:25Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
       ENDDO
-    ENDIF
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+    ENDDO
+!$OMP END PARALLEL DO
   ELSE
-    IFLD = 0
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        IFLD = IFLD+1
-        ITAG = MTAGDISTGP+JFLD
-        DO JROC=1,NPROC
-          CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-           &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),&
-           &CDSTRING='DIST_GRID_CTL')
-        ENDDO
-      ENDIF
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+!$OMP PARALLEL PRIVATE(JGL,JKGLO,IEND,IBL)
+!$OMP DO SCHEDULE(STATIC) 
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+      ENDDO
+!$OMP END DO
+!$OMP DO SCHEDULE(STATIC)
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+!$OMP END DO
+!$OMP END PARALLEL
     ENDDO
   ENDIF
-      
+  CALL GSTATS(1663,1)
 
-! Wait for sends and receives to complete
+ENDIF
 
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 1')
+! Wait for recv to complete and fill
+DO JR=1, IR
+  CALL GSTATS(811,0)
+  CALL MPL_WAITANY(KREQUEST=IRCVREQ(1:IR), KINDEX=INR, CDSTRING='DIST_GRID_CTL: WAIT FOR RECV')
+  CALL GSTATS(811,1)
+  CALL GSTATS(1663,0)
+  IFLDCOUNT=0
+  DO JFLD=1,KFDISTG
+    IF(KFROM(JFLD) == IPROC(INR)) THEN
+      IFLDCOUNT = IFLDCOUNT+1
+      IFLDLOC(IFLDCOUNT)=JFLD
     ENDIF
-    CALL MPL_WAIT(KREQUEST=IRECVREQ(1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 2')
+  ENDDO
+!$OMP PARALLEL PRIVATE(JFLD,JKGLO,IEND,IBL,ILOCFLD)
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
  !$OMP PARALLEL PRIVATE(JFLD,JKGLO,IEND,IBL,ILOCFLD)
```
created_at: 2025-03-19T16:58:45Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
       ENDDO
-    ENDIF
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+    ENDDO
+!$OMP END PARALLEL DO
   ELSE
-    IFLD = 0
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        IFLD = IFLD+1
-        ITAG = MTAGDISTGP+JFLD
-        DO JROC=1,NPROC
-          CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-           &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),&
-           &CDSTRING='DIST_GRID_CTL')
-        ENDDO
-      ENDIF
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+!$OMP PARALLEL PRIVATE(JGL,JKGLO,IEND,IBL)
+!$OMP DO SCHEDULE(STATIC) 
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+      ENDDO
+!$OMP END DO
+!$OMP DO SCHEDULE(STATIC)
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+!$OMP END DO
+!$OMP END PARALLEL
     ENDDO
   ENDIF
-      
+  CALL GSTATS(1663,1)
 
-! Wait for sends and receives to complete
+ENDIF
 
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 1')
+! Wait for recv to complete and fill
+DO JR=1, IR
+  CALL GSTATS(811,0)
+  CALL MPL_WAITANY(KREQUEST=IRCVREQ(1:IR), KINDEX=INR, CDSTRING='DIST_GRID_CTL: WAIT FOR RECV')
+  CALL GSTATS(811,1)
+  CALL GSTATS(1663,0)
+  IFLDCOUNT=0
+  DO JFLD=1,KFDISTG
+    IF(KFROM(JFLD) == IPROC(INR)) THEN
+      IFLDCOUNT = IFLDCOUNT+1
+      IFLDLOC(IFLDCOUNT)=JFLD
     ENDIF
-    CALL MPL_WAIT(KREQUEST=IRECVREQ(1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 2')
+  ENDDO
+!$OMP PARALLEL PRIVATE(JFLD,JKGLO,IEND,IBL,ILOCFLD)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP DO SCHEDULE(STATIC)
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
    !$OMP DO SCHEDULE(STATIC)
```
created_at: 2025-03-19T16:58:55Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
       ENDDO
-    ENDIF
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+    ENDDO
+!$OMP END PARALLEL DO
   ELSE
-    IFLD = 0
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        IFLD = IFLD+1
-        ITAG = MTAGDISTGP+JFLD
-        DO JROC=1,NPROC
-          CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-           &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),&
-           &CDSTRING='DIST_GRID_CTL')
-        ENDDO
-      ENDIF
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+!$OMP PARALLEL PRIVATE(JGL,JKGLO,IEND,IBL)
+!$OMP DO SCHEDULE(STATIC) 
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+      ENDDO
+!$OMP END DO
+!$OMP DO SCHEDULE(STATIC)
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+!$OMP END DO
+!$OMP END PARALLEL
     ENDDO
   ENDIF
-      
+  CALL GSTATS(1663,1)
 
-! Wait for sends and receives to complete
+ENDIF
 
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 1')
+! Wait for recv to complete and fill
+DO JR=1, IR
+  CALL GSTATS(811,0)
+  CALL MPL_WAITANY(KREQUEST=IRCVREQ(1:IR), KINDEX=INR, CDSTRING='DIST_GRID_CTL: WAIT FOR RECV')
+  CALL GSTATS(811,1)
+  CALL GSTATS(1663,0)
+  IFLDCOUNT=0
+  DO JFLD=1,KFDISTG
+    IF(KFROM(JFLD) == IPROC(INR)) THEN
+      IFLDCOUNT = IFLDCOUNT+1
+      IFLDLOC(IFLDCOUNT)=JFLD
     ENDIF
-    CALL MPL_WAIT(KREQUEST=IRECVREQ(1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 2')
+  ENDDO
+!$OMP PARALLEL PRIVATE(JFLD,JKGLO,IEND,IBL,ILOCFLD)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP DO SCHEDULE(STATIC)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZRCV(JKGLO:JKGLO+IEND-1,IOFFPROC(INR)+JFLD)
+      ENDDO
+    ENDDO
+!$OMP END DO
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
    !$OMP END DO
```
created_at: 2025-03-19T16:59:06Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
       ENDDO
-    ENDIF
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+    ENDDO
+!$OMP END PARALLEL DO
   ELSE
-    IFLD = 0
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        IFLD = IFLD+1
-        ITAG = MTAGDISTGP+JFLD
-        DO JROC=1,NPROC
-          CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-           &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),&
-           &CDSTRING='DIST_GRID_CTL')
-        ENDDO
-      ENDIF
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+!$OMP PARALLEL PRIVATE(JGL,JKGLO,IEND,IBL)
+!$OMP DO SCHEDULE(STATIC) 
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+      ENDDO
+!$OMP END DO
+!$OMP DO SCHEDULE(STATIC)
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+!$OMP END DO
+!$OMP END PARALLEL
     ENDDO
   ENDIF
-      
+  CALL GSTATS(1663,1)
 
-! Wait for sends and receives to complete
+ENDIF
 
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 1')
+! Wait for recv to complete and fill
+DO JR=1, IR
+  CALL GSTATS(811,0)
+  CALL MPL_WAITANY(KREQUEST=IRCVREQ(1:IR), KINDEX=INR, CDSTRING='DIST_GRID_CTL: WAIT FOR RECV')
+  CALL GSTATS(811,1)
+  CALL GSTATS(1663,0)
+  IFLDCOUNT=0
+  DO JFLD=1,KFDISTG
+    IF(KFROM(JFLD) == IPROC(INR)) THEN
+      IFLDCOUNT = IFLDCOUNT+1
+      IFLDLOC(IFLDCOUNT)=JFLD
     ENDIF
-    CALL MPL_WAIT(KREQUEST=IRECVREQ(1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 2')
+  ENDDO
+!$OMP PARALLEL PRIVATE(JFLD,JKGLO,IEND,IBL,ILOCFLD)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP DO SCHEDULE(STATIC)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZRCV(JKGLO:JKGLO+IEND-1,IOFFPROC(INR)+JFLD)
+      ENDDO
+    ENDDO
+!$OMP END DO
   ELSE
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        CALL MPL_WAIT(KREQUEST=ISENDREQ(:,JFLD), &
-         & CDSTRING='DIST_GRID_CTL: WAIT 3')
-      ENDIF
-      CALL MPL_WAIT(KREQUEST=IRECVREQ(JFLD), &
-         & CDSTRING='DIST_GRID_CTL: WAIT 4')
+!$OMP DO SCHEDULE(STATIC)
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
    !$OMP DO SCHEDULE(STATIC)
```
created_at: 2025-03-19T16:59:18Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
       ENDDO
-    ENDIF
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+    ENDDO
+!$OMP END PARALLEL DO
   ELSE
-    IFLD = 0
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        IFLD = IFLD+1
-        ITAG = MTAGDISTGP+JFLD
-        DO JROC=1,NPROC
-          CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-           &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),&
-           &CDSTRING='DIST_GRID_CTL')
-        ENDDO
-      ENDIF
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+!$OMP PARALLEL PRIVATE(JGL,JKGLO,IEND,IBL)
+!$OMP DO SCHEDULE(STATIC) 
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+      ENDDO
+!$OMP END DO
+!$OMP DO SCHEDULE(STATIC)
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+!$OMP END DO
+!$OMP END PARALLEL
     ENDDO
   ENDIF
-      
+  CALL GSTATS(1663,1)
 
-! Wait for sends and receives to complete
+ENDIF
 
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 1')
+! Wait for recv to complete and fill
+DO JR=1, IR
+  CALL GSTATS(811,0)
+  CALL MPL_WAITANY(KREQUEST=IRCVREQ(1:IR), KINDEX=INR, CDSTRING='DIST_GRID_CTL: WAIT FOR RECV')
+  CALL GSTATS(811,1)
+  CALL GSTATS(1663,0)
+  IFLDCOUNT=0
+  DO JFLD=1,KFDISTG
+    IF(KFROM(JFLD) == IPROC(INR)) THEN
+      IFLDCOUNT = IFLDCOUNT+1
+      IFLDLOC(IFLDCOUNT)=JFLD
     ENDIF
-    CALL MPL_WAIT(KREQUEST=IRECVREQ(1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 2')
+  ENDDO
+!$OMP PARALLEL PRIVATE(JFLD,JKGLO,IEND,IBL,ILOCFLD)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP DO SCHEDULE(STATIC)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZRCV(JKGLO:JKGLO+IEND-1,IOFFPROC(INR)+JFLD)
+      ENDDO
+    ENDDO
+!$OMP END DO
   ELSE
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        CALL MPL_WAIT(KREQUEST=ISENDREQ(:,JFLD), &
-         & CDSTRING='DIST_GRID_CTL: WAIT 3')
-      ENDIF
-      CALL MPL_WAIT(KREQUEST=IRECVREQ(JFLD), &
-         & CDSTRING='DIST_GRID_CTL: WAIT 4')
+!$OMP DO SCHEDULE(STATIC)
+    DO JKGLO=1,D%NGPTOT,KPROMA
+      DO JFLD=1,IFLDCOUNT
+        ILOCFLD=ISORT(IFLDLOC(JFLD))
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZRCV(JKGLO:JKGLO+IEND-1,IOFFPROC(INR)+JFLD)
+      ENDDO
     ENDDO
+!$OMP END DO
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
    !$OMP END DO
```
created_at: 2025-03-19T16:59:28Z
author_association: COLLABORATOR
diff_hunk: @@ -94,178 +94,220 @@ SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT)
   ENDDO
 ENDIF
 
-! Copy for single PE
-
-IF(NPROC == 1) THEN
-!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
-  DO JKGLO=1,D%NGPTOT,KPROMA
-    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
-    IOFF = JKGLO-1
-    IBL  = (JKGLO-1)/KPROMA+1
-    DO JFLD=1,KFDISTG
-      DO JROF=1,IEND
-        PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD)
-      ENDDO
-    ENDDO
-  ENDDO
-!$OMP END PARALLEL DO
-
-ELSEIF(KFDISTG>0) THEN
+ALLOCATE(IOFFGP(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(IOFFA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
+ALLOCATE(ILONA(MINVAL(D%NFRSTLAT(:)):MAXVAL(D%NLSTLAT(:))))
 
-! test if values in KFROM are all the same
-  LLSAME=.TRUE.
-  IFROM=KFROM(1)
-  DO JFLD=2,KFDISTG
-    IF(KFROM(JFLD) /= IFROM) THEN
-      LLSAME=.FALSE.
-      EXIT
-    ENDIF
-  ENDDO
+ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
 
-  IMYFIELDS = 0
-  DO JFLD=1,KFDISTG
-    IF(KFROM(JFLD) == MYPROC) THEN
-      IMYFIELDS = IMYFIELDS+1
+IR=0
+! Post receives
+IOFFPROC(1)=0
+DO JROC=1,NPROC
+  IF (JROC /= MYPROC) THEN
+    IF (ANY(KFROM(1:KFDISTG) == JROC)) THEN
+      ITAG = MTAGDISTGP
+      IR=IR+1
+      CALL GSTATS(811,0)
+      CALL MPL_RECV(ZRCV(:,IOFFPROC(IR)+1:IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)),&
+       & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRCVREQ(IR), &
+       & KSOURCE=NPRCIDS(JROC),KTAG=ITAG,CDSTRING='DIST_GRID_CTL:')
+      CALL GSTATS(811,1)
+      IPROC(IR)=JROC
+      IOFFPROC(IR+1)=IOFFPROC(IR)+COUNT(KFROM(1:KFDISTG) == JROC)
     ENDIF
-  ENDDO
+  ENDIF
+ENDDO
 
-  CALL GSTATS(1663,0)
-  IF(IMYFIELDS > 0) THEN
-    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))
-
-!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
-!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
-!$OMP&ILOFF,JGL,JLON)
-    DO JFLD=1,IMYFIELDS
-      DO JA=1,N_REGIONS_NS
-        DO JB=1,N_REGIONS(JA)
-          CALL SET2PE(ISND,JA,JB,0,0)
-
-          IGLOFF = D%NPTRFRSTLAT(JA)
-          IGL1   = D%NFRSTLAT(JA)
-          IGL2   = D%NLSTLAT(JA)
+! Fill and send
+ALLOCATE (ZBUF(D%NGPTOTMX,COUNT(KFROM(:) == MYPROC),NPROC))
+IF (SIZE(ZBUF) > 0) THEN
+  ! Force allocation right here, not inside the open-mp region below :
+  ZBUF(1,1,1)=HUGE(1._JPRB)
+ENDIF
+IS=0
+IFLDCOUNT=0
+DO JFLD=1,KFDISTG
+  IF(KFROM(JFLD) == MYPROC) THEN
+    IFLDCOUNT = IFLDCOUNT+1
+    IFLDLOC(IFLDCOUNT)=JFLD
+  ENDIF
+ENDDO
+IF(IFLDCOUNT > 0) THEN
+  DO JA=1,N_REGIONS_NS
+    IGLOFF = D%NPTRFRSTLAT(JA)
+    IGL1   = D%NFRSTLAT(JA)
+    IGL2   = D%NLSTLAT(JA)
+    DO JB=1,N_REGIONS(JA)
+      CALL SET2PE(ITO,JA,JB,0,0)
+      IF (ITO /= MYPROC) THEN
+        IF(JA == 1) THEN
           IOFF = 0
-          IF(JA > 1) THEN
-            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
-              ILAST = D%NLSTLAT(JA-1)-1
-            ELSE
-              ILAST = D%NLSTLAT(JA-1)
-            ENDIF
-            DO J=D%NFRSTLAT(1),ILAST
-              IOFF = IOFF+G%NLOEN(J)
-            ENDDO
+        ELSE
+          IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+          ELSE
+            IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
           ENDIF
-          
-          ILEN(ISND,JFLD) = 0
-          ILOFF = 0
+        ENDIF
+        IOFFGP(IGL1) = 0
+        IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+        DO JGL=IGL1,IGL2-1
+          ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+          IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+          IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+        ENDDO
+        ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+        CALL GSTATS(1663,0)
+!$OMP PARALLEL PRIVATE(JFLD,JGL)
+        IF (IFLDCOUNT > IGL2-IGL1+1) THEN
+!$OMP DO SCHEDULE(STATIC)
+          DO JFLD=1,IFLDCOUNT
+            DO JGL=IGL1,IGL2
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+            ENDDO
+          ENDDO
+!$OMP END DO
+        ELSE
+!$OMP DO SCHEDULE(STATIC)
           DO JGL=IGL1,IGL2
-            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
-              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
-               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
+            DO JFLD=1,IFLDCOUNT
+              ZBUF(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL),JFLD,ITO) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
             ENDDO
-            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
-            ILOFF = ILOFF + G%NLOEN(JGL)
           ENDDO
-        ENDDO
-      ENDDO
+!$OMP END DO
+        ENDIF
+!$OMP END PARALLEL
+        CALL GSTATS(1663,1)
+        ITAG = MTAGDISTGP
+        IS=IS+1
+        CALL GSTATS(811,0)
+        CALL MPL_SEND(ZBUF(:,:,ITO),KDEST=NPRCIDS(ITO),KTAG=ITAG,&
+         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IS),&
+         &CDSTRING='DIST_GRID_CTL')
+        CALL GSTATS(811,1)
+      ENDIF
     ENDDO
-!$OMP END PARALLEL DO
-  ENDIF
-  CALL GSTATS(1663,1)
-    
-  ! Message passing
-  CALL GSTATS_BARRIER(791)
-  CALL GSTATS(811,0)
-  ! Receive
-
-  ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG))
-
-  IF( LLSAME )THEN
-    IRCV = KFROM(1)
-    ITAG = MTAGDISTGP
-    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-     &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:')
+  ENDDO
+ENDIF
+  
+! Message passing
+CALL GSTATS_BARRIER(791)
+
+IGPBLKS = (D%NGPTOT-1)/KPROMA+1 
+
+IF(IFLDCOUNT > 0) THEN
+  ! Transfert for myself :
+  CALL PE2SET(MYPROC,JA,JB,IW,IV)
+  IGLOFF = D%NPTRFRSTLAT(JA)
+  IGL1   = D%NFRSTLAT(JA)
+  IGL2   = D%NLSTLAT(JA)
+  IF(JA == 1) THEN
+    IOFF = 0
   ELSE
-    DO JFLD=1,KFDISTG
-      IRCV = KFROM(JFLD)
-      ITAG = MTAGDISTGP+JFLD
-      CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
-       &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:')
-    ENDDO
-  ENDIF
-
+    IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)-1))
+    ELSE
+      IOFF = SUM(G%NLOEN(D%NFRSTLAT(1):D%NLSTLAT(JA-1)))
+    ENDIF
 
-  ! Send
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      ITAG = MTAGDISTGP
-      DO JROC=1,NPROC
-        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
-         &CDSTRING='DIST_GRID_CTL')
+  ENDIF
+  IOFFGP(IGL1) = 0
+  IOFFA(IGL1)=IOFF+D%NSTA(IGLOFF,JB)
+  DO JGL=IGL1,IGL2-1
+    ILONA(JGL)=D%NONL(IGLOFF+JGL-IGL1,JB)
+    IOFFGP(JGL+1) = SUM(D%NONL(IGLOFF:IGLOFF+JGL-IGL1,JB))
+    IOFFA(JGL+1)=IOFF+SUM(G%NLOEN(IGL1:JGL))+D%NSTA(IGLOFF+JGL-IGL1+1,JB)
+  ENDDO
+  ILONA(IGL2)=D%NONL(IGLOFF+IGL2-IGL1,JB)
+  CALL GSTATS(1663,0)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGL,JKGLO,IEND,IBL,ZGP,ILOCFLD)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
       ENDDO
-    ENDIF
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+    ENDDO
+!$OMP END PARALLEL DO
   ELSE
-    IFLD = 0
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        IFLD = IFLD+1
-        ITAG = MTAGDISTGP+JFLD
-        DO JROC=1,NPROC
-          CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
-           &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),&
-           &CDSTRING='DIST_GRID_CTL')
-        ENDDO
-      ENDIF
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+!$OMP PARALLEL PRIVATE(JGL,JKGLO,IEND,IBL)
+!$OMP DO SCHEDULE(STATIC) 
+      DO JGL=IGL1,IGL2
+        ZGP(IOFFGP(JGL)+1:IOFFGP(JGL)+ILONA(JGL)) = PGPG(IOFFA(JGL):IOFFA(JGL)+ILONA(JGL)-1,JFLD)
+      ENDDO
+!$OMP END DO
+!$OMP DO SCHEDULE(STATIC)
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZGP(JKGLO:JKGLO+IEND-1)
+      ENDDO
+!$OMP END DO
+!$OMP END PARALLEL
     ENDDO
   ENDIF
-      
+  CALL GSTATS(1663,1)
 
-! Wait for sends and receives to complete
+ENDIF
 
-  IF( LLSAME )THEN
-    IF(KFROM(1) == MYPROC) THEN
-      CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 1')
+! Wait for recv to complete and fill
+DO JR=1, IR
+  CALL GSTATS(811,0)
+  CALL MPL_WAITANY(KREQUEST=IRCVREQ(1:IR), KINDEX=INR, CDSTRING='DIST_GRID_CTL: WAIT FOR RECV')
+  CALL GSTATS(811,1)
+  CALL GSTATS(1663,0)
+  IFLDCOUNT=0
+  DO JFLD=1,KFDISTG
+    IF(KFROM(JFLD) == IPROC(INR)) THEN
+      IFLDCOUNT = IFLDCOUNT+1
+      IFLDLOC(IFLDCOUNT)=JFLD
     ENDIF
-    CALL MPL_WAIT(KREQUEST=IRECVREQ(1), &
-       & CDSTRING='DIST_GRID_CTL: WAIT 2')
+  ENDDO
+!$OMP PARALLEL PRIVATE(JFLD,JKGLO,IEND,IBL,ILOCFLD)
+  IF (IFLDCOUNT > IGPBLKS) THEN
+!$OMP DO SCHEDULE(STATIC)
+    DO JFLD=1,IFLDCOUNT
+      ILOCFLD=ISORT(IFLDLOC(JFLD))
+      DO JKGLO=1,D%NGPTOT,KPROMA
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZRCV(JKGLO:JKGLO+IEND-1,IOFFPROC(INR)+JFLD)
+      ENDDO
+    ENDDO
+!$OMP END DO
   ELSE
-    DO JFLD=1,KFDISTG
-      IF(KFROM(JFLD) == MYPROC) THEN
-        CALL MPL_WAIT(KREQUEST=ISENDREQ(:,JFLD), &
-         & CDSTRING='DIST_GRID_CTL: WAIT 3')
-      ENDIF
-      CALL MPL_WAIT(KREQUEST=IRECVREQ(JFLD), &
-         & CDSTRING='DIST_GRID_CTL: WAIT 4')
+!$OMP DO SCHEDULE(STATIC)
+    DO JKGLO=1,D%NGPTOT,KPROMA
+      DO JFLD=1,IFLDCOUNT
+        ILOCFLD=ISORT(IFLDLOC(JFLD))
+        IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
+        IBL  = (JKGLO-1)/KPROMA+1
+        PGP(1:IEND,ILOCFLD,IBL) = ZRCV(JKGLO:JKGLO+IEND-1,IOFFPROC(INR)+JFLD)
+      ENDDO
     ENDDO
+!$OMP END DO
   ENDIF
+!$OMP END PARALLEL
path: src/trans/cpu/internal/dist_grid_ctl_mod.F90
user: login: samhatfield
body: ```suggestion
  !$OMP END PARALLEL
```
created_at: 2025-03-19T16:59:38Z
author_association: COLLABORATOR

PR comments:
user: login: samhatfield
created_at: 2025-03-13T09:26:00Z
body: Thanks @AlexandreMary - we'll take a look.
author_association: COLLABORATOR
user: login: samhatfield
created_at: 2025-03-19T16:41:01Z
body: @AlexandreMary could you rebase this branch against develop? Then the tests will all pass.
author_association: COLLABORATOR
user: login: samhatfield
created_at: 2025-03-20T11:34:24Z
body: I've rebased this branch against develop for my own testing [here](https://github.com/samhatfield/ectrans/tree/report_opt_ryad_rebased). @AlexandreMary could you do the same for your branch, or just `git reset --hard` against mine, and update this PR?

This program can be used for bit reproducibility testing:

<details>

<summary>Reproducibility test program </summary>

```fortran
PROGRAM TEST_DIST_GRID

USE PARKIND1, ONLY: JPIM, JPRB
USE MPL_MODULE, ONLY: MPL_INIT, MPL_MYRANK, MPL_NPROC, MPL_BARRIER, MPL_END

IMPLICIT NONE

#include "setup_trans0.h"
#include "setup_trans.h"
#include "trans_inq.h"
#include "dist_grid.h"
#include "trans_end.h"

INTEGER(KIND=JPIM), PARAMETER :: JPSMAX = 159 ! T159 spectral resolution
INTEGER(KIND=JPIM), PARAMETER :: JPPROMA = 16
INTEGER(KIND=JPIM), PARAMETER :: JPFDISTG = 100
INTEGER(KIND=JPIM), PARAMETER :: JPNLAT = 2 * (JPSMAX + 1)

INTEGER(KIND=JPIM) :: IPROC, IMYPROC, IPRGPNS, IPRGPEW, IPRTRW, IPRTRV, IGPTOTG, IGPTOT, IGPBLKS

REAL(KIND=JPRB), ALLOCATABLE :: ZGPG(:,:)
INTEGER(KIND=JPIM) :: IFROM(JPFDISTG)
REAL(KIND=JPRB), ALLOCATABLE :: ZGP(:,:,:)
INTEGER(KIND=JPIM) :: NLOEN(JPNLAT)

LOGICAL :: LLUSE_MPI
INTEGER(KIND=JPIM) :: JA, JB, JL, JG, JF
REAL(KIND=JPRB) :: ZRAND

LLUSE_MPI = DETECT_MPIRUN()

! Set up MPI
IF (LLUSE_MPI) THEN
  CALL MPL_INIT
  IMYPROC = MPL_MYRANK()
  IPROC = MPL_NPROC()
ELSE
  IMYPROC = 1
  IPROC  = 1
ENDIF

! Compute E-W and V-W set sizes
DO JA = INT(SQRT(REAL(IPROC,JPRB))), IPROC
  JB = IPROC / JA
  IF (JA * JB == IPROC) THEN
    IPRGPNS = MAX(JA, JB)
    IPRGPEW = MIN(JA, JB)
    IPRTRW  = MAX(JA, JB)
    IPRTRV  = MIN(JA, JB)
  ENDIF
ENDDO

! Compute octahedral latitudes
DO JL = 1, JPNLAT / 2
  NLOEN(JL) = 20 + 4 * (JL - 1)
  NLOEN(JPNLAT - JL + 1) = NLOEN(JL)
END DO

! Initialise ecTrans
CALL SETUP_TRANS0(KPRGPNS=IPRGPNS, KPRGPEW=IPRGPEW, KPRTRW=IPRTRW, LDMPOFF=.NOT. LLUSE_MPI)
CALL SETUP_TRANS(KSMAX=JPSMAX, KDGL=2 * (JPSMAX + 1), KLOEN=NLOEN)
CALL TRANS_INQ(KGPTOTG=IGPTOTG, KGPTOT=IGPTOT)

! Initialise receiving grid point array
IGPBLKS = (IGPTOT - 1) / JPPROMA + 1
ALLOCATE(ZGP(JPPROMA,JPFDISTG,IGPBLKS))
IFROM(:) = 1

! Fill input array with random numbers and distribute
CALL RANDOM_INIT(REPEATABLE=.TRUE., IMAGE_DISTINCT=.TRUE.) ! PRNG is same every time
IF (IMYPROC == 1) THEN
  ALLOCATE(ZGPG(IGPTOTG,JPFDISTG))
  DO JG = 1, IGPTOTG
    DO JF = 1, JPFDISTG
      CALL RANDOM_NUMBER(ZRAND)
      ZGPG(JG,JF) = (1.0_JPRB - 2.0_JPRB * ZRAND)
    ENDDO
  ENDDO
  CALL DIST_GRID(PGPG=ZGPG, KPROMA=JPPROMA, KFDISTG=JPFDISTG, KFROM=IFROM, PGP=ZGP)
ELSE
  CALL DIST_GRID(KPROMA=JPPROMA, KFDISTG=JPFDISTG, KFROM=IFROM, PGP=ZGP)
ENDIF

! Each task writes its sum to fort.<1000+MYPROC>
WRITE(1000+IMYPROC,*) SUM(ZGP)

! Finalise
CALL TRANS_END
IF (LLUSE_MPI) THEN
  CALL MPL_BARRIER()
  CALL MPL_END
ENDIF

CONTAINS

FUNCTION DETECT_MPIRUN() RESULT(LMPI_REQUIRED)
  USE EC_ENV_MOD, ONLY : EC_PUTENV
  LOGICAL :: LMPI_REQUIRED
  INTEGER :: ILEN
  INTEGER, PARAMETER :: NVARS = 4
  CHARACTER(LEN=32), DIMENSION(NVARS) :: CMPIRUN_DETECT
  CHARACTER(LEN=4) :: CLENV
  INTEGER :: IVAR
  
  ! Environment variables that are set when mpirun, srun, aprun, ... are used
  CMPIRUN_DETECT(1) = 'OMPI_COMM_WORLD_SIZE'  ! OPENMPI
  CMPIRUN_DETECT(2) = 'ALPS_APP_PE'           ! CRAY PE
  CMPIRUN_DETECT(3) = 'PMI_SIZE'              ! INTEL
  CMPIRUN_DETECT(4) = 'SLURM_NTASKS'          ! SLURM
  
  LMPI_REQUIRED = .FALSE.
  DO IVAR = 1, NVARS
    CALL GET_ENVIRONMENT_VARIABLE(NAME=TRIM(CMPIRUN_DETECT(IVAR)), LENGTH=ILEN)
    IF (ILEN > 0) THEN
      LMPI_REQUIRED = .TRUE.
      EXIT ! Break
    ENDIF
  ENDDO
  
  CALL GET_ENVIRONMENT_VARIABLE(NAME="ECTRANS_USE_MPI", VALUE=CLENV, LENGTH=ILEN )
  IF (ILEN > 0) THEN
    LMPI_REQUIRED = .TRUE.
    IF( TRIM(CLENV) == "0" .OR. TRIM(CLENV) == "OFF" .OR. TRIM(CLENV) == "OFF" .OR. TRIM(CLENV) == "F" ) THEN
      LMPI_REQUIRED = .FALSE.
    ENDIF
    CALL EC_PUTENV("DR_HOOK_ASSERT_MPI_INITIALIZED=0", OVERWRITE=.TRUE.)
  ENDIF
END FUNCTION
  
END PROGRAM TEST_DIST_GRID
```

</details>

Task 1 fills its global grid point array of 100 fields with random numbers then distributes them to the other tasks. Each task calculates its sum and writes to a separate file.

Result from develop branch (each line taken from each task):
```
 24.5364780
 19.1892109
 469.801971
-8.27241039
 645.418518
-738.771973
 77.6903152
 51.1948586
 582.808472
-41.5211029
```

Result from this branch:
```
 24.5364780
 19.1892109
 469.801971
-8.27241039
 645.418518
-738.771973
 77.6903152
 51.1948586
 582.808472
-41.5211029
```

All good, so once that rebase is done, I think we are fine to merge this.
author_association: COLLABORATOR
user: login: samhatfield
created_at: 2025-03-28T11:58:12Z
body: Nevermind, didn't realise I can rebase myself.
author_association: COLLABORATOR