SUBROUTINE SUMP

!**** *SUMP * - Routine to initialize parallel environment

!     Purpose.
!     --------
!           Initialize yommp common block variables

!**   Interface.
!     ----------
!        *CALL* *SUMP *

!        Explicit arguments :
!        --------------------

!        Implicit arguments :
!        --------------------
!              COMMON YOMMP

!     Method.
!     -------
!        See documentation

!     Externals.   NONE.
!     ----------

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        MPP Group *ECMWF*

!     Modifications.
!     --------------
!        Original   : 95-10-01
!        L. Isaksen : 96-02-20  NSPEC2MX added
!        K. YESSAD (APRIL 1997): add NPROCGP.
!        Modified : ??-??-?? J.Latour ?? tidied up by M.Hamrud
!        Modified : ??-??-?? J.Latour optimised computation of NPROCGP
!        Modified : 98-10-06 R. El Khatib move SUPROCGP etc to SUPROCFP
!        Modified : 98-12-09 C.Fischer remove doubly used array nbsetlev 
!        Modified 99-02-17 by K. YESSAD: options LRETCFOU, LWRTCFOU.
!        Modified : 99-07-05 D.Salmond NULTPP and NPTRLS replaced by
!                            IULTPP and IPTRLS in first call to SUMPLAT
!                            Dimension of IGPTOTL changed to NPRGPNS/EW
!        Modified : 00-02-02 M.Hamrud Cleaning of parallel environment
!                            Splitting of SUMPLAT into SUMPLAT and SUMPLATF
!                            Removal of unused options NPHASE, LBIDIR, LAPPLE
!        Modified : 00-04-11 C Fischer Put back ndlunl/ndluxl/ndgunl
!                            from yomdim
!        Modified : 00-11-01 M Hamrud : Intro of TRANS package
!        Modified : 00-09-05 K. YESSAD: relaxation of thin layer hypothesis.
!        R. El Khatib 01-08-24 Cleaning on the loop initializing NPTRMF
!        Modified : 02-03-08 Y.Tremolet Setup distributed spectral field type.
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        20-Feb-2005 J. Vivoda  GWADV scheme for PC_FULL (d3,d4)
!        M.Hamrud      01-May-2006 Generalized IO scheme
!        K. Yessad 07-03-2007: Remove useless (gw)_surf interpol. in NH+LGWADV.
!   N. Wedi and K. Yessad (Jan 2008): different dev for NH model and PC scheme
!     End Modifications
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMMP    , ONLY : LSPLIT   ,MYPROC   ,LEQ_REGIONS ,&
 & MYSETA   ,MYSETW   ,MYSETV  ,MY_REGION_NS  ,MY_REGION_EW ,NGPSET2PE ,&
 & NUMPP    ,NPROCM   ,&
 & NPTRMS   ,NALLMS   ,&
 & NPTRLS   ,NPTRSV   ,NPTRCV   ,NPTRTV   ,NPSURF   ,&
 & NPTRSVF  ,NPTRMF   ,NSPSTAF  ,NUMLL    ,NPTRLL   ,&
 & NUMVMO   ,NUMVMOJB ,MYLEVS   ,&
 & NSTA     ,NONL     ,NPTRFRSTLAT,NPTRLSTLAT,&
 & NPTRLAT  ,NFRSTLAT ,NLSTLAT  ,NBSETLEV ,&
 & LSPLITLAT,MYLATS   ,NVMODIST ,&
 & NSPEC2V  ,&
 & NCPEC2V  ,NTPEC2V  ,NSPEC2VF ,NBSETSP  ,NFRSTLOFF,&
 & MYFRSTACTLAT,MYLSTACTLAT,NPTRFLOFF,NUMXPP,&
 & NGLOBALINDEX ,NGLOBALPROC ,NLOCALINDEX
USE YOMMPG   , ONLY : NPOSSP   ,NDIM0G
USE YOMDIM   , ONLY :       NDGLG    ,&
 & NDGLL    ,NDGSAG   ,NDGSAL   ,NDGENG   ,&
 & NDGENL   ,NFLEVL   ,NFLEVG   ,NPROMA   ,&
 & NPROMM   ,NPROMNH  ,NSMAX    ,&
 & NSPEC    ,NSPEC2   ,NSPEC2MX ,NCMAX    ,&
 & NDGUNL   ,NDGUXL   ,NDGUXG   ,NCPEC    ,NCPEC2   ,NXMAX    ,NTMAX    ,&
 & NTPEC2   ,NUMP     ,NUMCP    ,NUMTP    ,NGPBLKS  ,&
 & NXPEC    ,NUMXP    ,NPROMVC  ,NDLON    ,&
 & NPROMDLW ,NPROMDLR ,NPROMDLR2,NPROMDLG ,&
 & LOPTPROMA,NMSMAX
USE YOMPLDSW , ONLY : LOPT_SCALAR
USE YOMDIMT  , ONLY : NPROMT
USE YOMLAP   , ONLY : NASM0    ,NACM0    ,NATM0    ,MYMS
USE YOMLUN   , ONLY : NULOUT   ,NULERR
USE YOMGEM   , ONLY : NLOENG   ,NSTTYP   ,NHTYP    ,NGPTOT   ,&
 & NGPTOTG  ,NGPTOTMX ,RMUCEN   ,RLOCEN   ,&
 & RSTRET   ,RNLGINC  ,NGPTOT_CAP,REFLRHC ,&
 & NGPTOTL  ,REFLCAPE ,REFLKUO   
USE YOMCT0   , ONLY : NCONF    ,NPROC    ,NPRINTLEV, &
 & NPRGPNS  ,NPRGPEW  ,NPRTRW   ,NPRTRNS  ,NPRTRV   ,LOUTPUT  ,LALLOPR  ,&
 & LWRTCFOU ,LELAM    ,N_REGIONS_NS ,N_REGIONS_EW ,N_REGIONS
USE YOMNMIA  , ONLY : NVMOD    ,NVMODPP  ,NVMODJB  ,NVMODJBPP
USE YOMINI   , ONLY : NEINI
USE YOMGRB   , ONLY : NGRBVO, NGRBD, NGRBT, NGRBQ, NGRBO3, NGRBLNSP
USE OML_MOD, ONLY : OML_MAX_THREADS
USE SPECTRAL_FIELDS_MOD
USE IOSTREAM_MIX , ONLY : INI_IOSTREAM

!     --------------------------------------x----------------------------

IMPLICIT NONE

INTEGER(KIND=JPIM) :: IAVE, IBSET, &
 & IENDL, IGL, I, III, IIMX, IITER, IK, &
 & ILBEG, ILEND, ILEV, IM, &
 & IND, INM, INSEF, INVMODMX, INVMODMXPP, &
 & IPRUSED, IRESTF, ISETW, ISETV, &
 & ISPEC2REM, ISTAL, JA, JB, JBSET, &
 & JGL, JJ, JL, JLEV, JLT, JMLOC, JNMODE, &
 & IGPBLKSMX, IMX, IPR, IPROMA, IPROMABEG, IPROMAEND, IPROC

INTEGER(KIND=JPIM) :: IGLOBAL(NDLON,NDGLG)
INTEGER(KIND=JPIM) :: IIC(NPRTRV), IMYMS(NCMAX+1)
INTEGER(KIND=JPIM) :: INUMTPP(NPRTRW), INUMCPP(NPRTRW)
INTEGER(KIND=JPIM), ALLOCATABLE :: INVMODIST(:,:)
INTEGER(KIND=JPIM) :: INUMSVF(NPRTRV+1)
INTEGER(KIND=JPIM) :: IULTPP(NPRTRNS)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

LOGICAL :: LLBAL, LLDONMI, LLVAR

!     INTEGER FUNCTIONS
INTEGER(KIND=JPIM) :: ITHRMAX

!      -----------------------------------------------------------------

#include "namgem.h"

!     ------------------------------------------------------------------

INTERFACE
#include "ini_spec_dist.h"
#include "trans_inq.h"
END INTERFACE

#include "abor1.intfb.h"
#include "sualmp1.intfb.h"
#include "sualmp2.intfb.h"
#include "set2pe.intfb.h"
#include "pe2set.intfb.h"

!     ------------------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('SUMP',0,ZHOOK_HANDLE)

!     ------------------------------------------------------------------

!  Allocate  arrays used in this routine

CALL SUALMP1

!*       1.    Initialize partitioning of wave numbers to PEs
!              ----------------------------------------------

CALL TRANS_INQ(KASM0=NASM0,KUMPP=NUMPP,KPOSSP=NPOSSP,KPTRMS=NPTRMS,&
 & KALLMS=NALLMS,KDIM0G=NDIM0G,&
 & KSPEC=NSPEC,KSPEC2=NSPEC2,KSPEC2MX=NSPEC2MX,KNUMP=NUMP)  

CALL INI_SPEC_DIST(NXMAX,NXMAX,&
 & NPRTRW,MYSETW,KUMPP=NUMXPP,&
 & KSPEC=NXPEC)
CALL INI_SPEC_DIST(NTMAX,NTMAX,&
 & NPRTRW,MYSETW,KASM0=NATM0,KUMPP=INUMTPP,&
 & KSPEC2=NTPEC2)
CALL INI_SPEC_DIST(NCMAX,NCMAX,&
 & NPRTRW,MYSETW,KASM0=NACM0,KPROCM=NPROCM,KUMPP=INUMCPP,&
 & KSPEC=NCPEC,KSPEC2=NCPEC2,KMYMS=IMYMS)  

NUMXP = NUMXPP(MYSETW)
NUMCP = INUMCPP(MYSETW)
NUMTP = INUMTPP(MYSETW)

! Retrieve distribution of latitude related data structures (grid-point space)

CALL TRANS_INQ(KFRSTLAT=NFRSTLAT,KLSTLAT=NLSTLAT,KFRSTLOFF=NFRSTLOFF,&
 & KPTRLAT=NPTRLAT,KPTRFRSTLAT=NPTRFRSTLAT,KPTRLSTLAT=NPTRLSTLAT,&
 & KPTRFLOFF=NPTRFLOFF,KONL=NONL(1:,:),KSTA=NSTA(1:,:),&
 & LDSPLITLAT=LSPLITLAT,&
 & KGPTOT=NGPTOT,KGPTOTG=NGPTOTG,KGPTOTMX=NGPTOTMX,KGPTOTL=NGPTOTL)  
! Fourier space (this should not really have to be known within the IFS)

CALL TRANS_INQ(KULTPP=IULTPP,KPTRLS=NPTRLS)

! update MY_REGION_NS and MY_REGION_EW
CALL PE2SET(MYPROC,MY_REGION_NS,MY_REGION_EW,ISETW,ISETV)

! initialise NGPSET2PE for faster mapping of gp sets to proc
DO JA=1,N_REGIONS_NS
  DO JB=1,N_REGIONS(JA)
    CALL SET2PE(NGPSET2PE(JA,JB),JA,JB,0,0)
  ENDDO
  DO JB=N_REGIONS(JA)+1,N_REGIONS_EW
    NGPSET2PE(JA,JB)=0
  ENDDO
ENDDO

IF (LOUTPUT) THEN
  WRITE(NULOUT,'(/'' OUTPUT FROM ROUTINE SUMP - PART 1:''/)')
  WRITE(NULOUT,'('' NPROC     NPRGPNS NPRGPEW NPRTRW  NPRTRV '')')
  WRITE(NULOUT,'(1X,I4,4(1X,I7))')NPROC,NPRGPNS,NPRGPEW,NPRTRW,NPRTRV
  WRITE(NULOUT,'('' MYPROC MYSETA MYSETB MYSETW MYSETV '')')
  WRITE(NULOUT,'(5(1X,I6))') MYPROC,MY_REGION_NS,MY_REGION_EW,MYSETW,MYSETV
  WRITE(NULOUT,'("LEQ_REGIONS=",L1)')LEQ_REGIONS
  IF( LEQ_REGIONS )THEN
    WRITE(NULOUT,'(" ")')
    WRITE(NULOUT,'("N_REGIONS_NS=",I4)')N_REGIONS_NS
    WRITE(NULOUT,'("N_REGIONS_EW=",I4)')N_REGIONS_EW
    WRITE(NULOUT,'("MY_REGION_NS=",I4)')MY_REGION_NS
    WRITE(NULOUT,'("MY_REGION_EW=",I4)')MY_REGION_EW
    DO JA=1,N_REGIONS_NS
      WRITE(NULOUT,'("N_REGIONS(",I5,")=",I3)')JA,N_REGIONS(JA)
    ENDDO
  ENDIF

  WRITE(NULOUT,'('' LSPLIT '')')
  WRITE(NULOUT,'(1X,L4)') LSPLIT
  WRITE(NULOUT,'('' NUMP NUMTP NUMCP'')')
  WRITE(NULOUT,'(4(1X,I4))') NUMP, NUMTP, NUMCP
  WRITE(NULOUT,'('' NUMPP '')')
  WRITE(NULOUT,'(20(1X,I4))')(NUMPP(JJ),JJ=1,NPRTRW)
  WRITE(NULOUT,*) "NUMBER OF THREADS",OML_MAX_THREADS()
  WRITE(NULOUT,'('' NPROCM '')')
  WRITE(NULOUT,'(20(1X,I4))')(NPROCM(JJ),JJ=0,NSMAX)
ENDIF

IF (LOUTPUT.AND.NPRINTLEV >= 1) THEN
  WRITE(UNIT=NULOUT,FMT='(/'' OUTPUT FROM ROUTINE SUMPLAT: ''/)')
  WRITE(UNIT=NULOUT,FMT='('' NFRSTLAT '')')
  WRITE(UNIT=NULOUT,FMT='(20(1X,I4))') NFRSTLAT(1:N_REGIONS_NS)
  WRITE(UNIT=NULOUT,FMT='('' NLSTLAT '')')
  WRITE(UNIT=NULOUT,FMT='(20(1X,I4))') NLSTLAT(1:N_REGIONS_NS)
  WRITE(UNIT=NULOUT,FMT='('' NFRSTLOFF  NPTRFLOFF '')')
  WRITE(UNIT=NULOUT,FMT='(2(1X,I6))') NFRSTLOFF, NPTRFLOFF
  WRITE(UNIT=NULOUT,FMT='('' NPTRLAT '')')
  WRITE(UNIT=NULOUT,FMT='(20(1X,I4))') NPTRLAT(1:NDGLG)
  WRITE(UNIT=NULOUT,FMT='('' LSPLITLAT '')')
  WRITE(UNIT=NULOUT,FMT='(50(1X,L1))') LSPLITLAT(1:NDGLG)
  WRITE(UNIT=NULOUT,FMT='('' NPTRFRSTLAT '')')
  WRITE(UNIT=NULOUT,FMT='(20(1X,I4))') NPTRFRSTLAT(1:N_REGIONS_NS)
  WRITE(UNIT=NULOUT,FMT='('' NPTRLSTLAT '')')
  WRITE(UNIT=NULOUT,FMT='(20(1X,I4))') NPTRLSTLAT(1:N_REGIONS_NS)
  WRITE(UNIT=NULOUT,FMT='(/)')
ENDIF

! Number of latitudes owned by each A-set member in Fourier space
NDGLL  = IULTPP(MYSETW)
NDGSAL = 1
NDGENL = NLSTLAT(MY_REGION_NS)-NFRSTLOFF

IF (NFRSTLAT(MY_REGION_NS)+IULTPP(MYSETW) <= NDGUXG) THEN
  NDGUXL=IULTPP(MYSETW)
  NDGUNL  = 1
ELSE
  NDGUXL=NDGUXG-NFRSTLAT(MY_REGION_NS)+1
  NDGUNL  = 1
ENDIF

! Compute first and last actual latitudes of local processor (grid-point)

MYFRSTACTLAT = NFRSTLAT(MY_REGION_NS)
MYLSTACTLAT  = NLSTLAT (MY_REGION_NS)
ILBEG=NFRSTLAT(MY_REGION_NS)-NFRSTLOFF
ILEND=NLSTLAT (MY_REGION_NS)-NFRSTLOFF

DO JGL=ILBEG,ILEND
  IF (NONL(NPTRFLOFF+JGL,MY_REGION_EW) == 0) THEN
    MYFRSTACTLAT = MYFRSTACTLAT+1
  ELSE
    EXIT
  ENDIF
ENDDO

DO JGL=ILEND,ILBEG,-1
  IF (NONL(NPTRFLOFF+JGL,MY_REGION_EW) == 0) THEN
    MYLSTACTLAT = MYLSTACTLAT-1
  ELSE
    EXIT
  ENDIF
ENDDO

! Code that handles control of 3D-transposition

!  Partitioning of spectral coefficients in semi-implicit calculations
!  Be careful : NSPEC2 varies between A-processor sets, so NPTRSV() 
!  differs on different A-processor sets.

INSEF=NSPEC2/NPRTRV
IRESTF=NSPEC2-INSEF*NPRTRV
NPTRSV(1)=1
DO JB=2,NPRTRV+1
  IF(JB-1 <= IRESTF) THEN
    NPTRSV(JB)=NPTRSV(JB-1)+INSEF+1
  ELSE
    NPTRSV(JB)=NPTRSV(JB-1)+INSEF
  ENDIF
ENDDO

INSEF=NCPEC2/NPRTRV
IRESTF=NCPEC2-INSEF*NPRTRV
NPTRCV(1)=1
DO JB=2,NPRTRV+1
  IF(JB-1 <= IRESTF) THEN
    NPTRCV(JB)=NPTRCV(JB-1)+INSEF+1
  ELSE
    NPTRCV(JB)=NPTRCV(JB-1)+INSEF
  ENDIF
ENDDO

INSEF=NTPEC2/NPRTRV
IRESTF=NTPEC2-INSEF*NPRTRV
NPTRTV(1)=1
DO JB=2,NPRTRV+1
  IF(JB-1 <= IRESTF) THEN
    NPTRTV(JB)=NPTRTV(JB-1)+INSEF+1
  ELSE
    NPTRTV(JB)=NPTRTV(JB-1)+INSEF
  ENDIF
ENDDO

!  Partitioning of spectral coefficients in semi-implicit calculations
!  for the case where complete m-columns are required.

IITER=0
DO
  IBSET=MIN(NPRTRV,NUMP)
  LLBAL=IITER /= 0
! At the first iteration NPTRMF is not yet initialized => the test is irrelevent
  IF (LLBAL) THEN
    DO JB=MIN(NPRTRV,2),IBSET
      IF( NPTRMF(JB) == -999 ) LLBAL=.FALSE.
    ENDDO
  ENDIF
  IF( LLBAL ) EXIT
  IITER=IITER+1
  NPTRMF(:)=-999
  INUMSVF(:)=0
  NPTRMF(1)=1
  NPTRMF(IBSET+1:NPRTRV+1)=NUMP+1
  IF(NUMP>0)THEN
    ISPEC2REM=NSPEC2
    IAVE=(ISPEC2REM-1)/IBSET+1-IITER
    DO JMLOC=NUMP,1,-1
      IM=IMYMS(JMLOC)
      INM=2*(NSMAX-IM+1)
      IF (INUMSVF(IBSET) < IAVE) THEN
        INUMSVF(IBSET)=INUMSVF(IBSET)+INM
      ELSE
        NPTRMF(IBSET)=JMLOC+1
        ISPEC2REM=ISPEC2REM-INUMSVF(IBSET)
        IBSET=IBSET-1
        IF (IBSET == 0) THEN
          CALL ABOR1('SUMP : PROBLEM PARTITIONING SPECTRAL SPACE')
        ENDIF
        IAVE=(ISPEC2REM-1)/IBSET+1-IITER
        INUMSVF(IBSET)=INUMSVF(IBSET)+INM
      ENDIF
    ENDDO
  ENDIF
ENDDO

NPTRSVF(1)=1
DO JB=2,NPRTRV+1
  NPTRSVF(JB)=NPTRSVF(JB-1)+INUMSVF(JB-1)
ENDDO

NSPSTAF(:)=-999
III=1
DO JMLOC=NPTRMF(MYSETV),NPTRMF(MYSETV+1)-1
  NSPSTAF(IMYMS(JMLOC))=III
  III=III+2*(NSMAX-IMYMS(JMLOC)+1)
ENDDO

IPRUSED=MIN(NFLEVG+1,NPRTRV)
NPTRLL(1)=1
DO JB=2,IPRUSED+1
  NPTRLL(JB)=NPTRLL(JB-1)+NUMLL(JB-1)
ENDDO

NBSETSP = IPRUSED

ILEV = 0
DO JB=1,NPRTRV
  DO JLEV=1,NUMLL(JB)
    ILEV = ILEV + 1
    NBSETLEV(ILEV) = JB
  ENDDO
ENDDO

DO JLEV=1,NFLEVL
  MYLEVS(JLEV) = NPTRLL(MYSETV)+JLEV-1
ENDDO
CALL INI_IOSTREAM(KBSETSP=NBSETSP,KBSETLEV=NBSETLEV,KFLEVG=NFLEVG,KSMAX=NSMAX,KDGLG=NDGLG,&
 & KLOENG=NLOENG(1:NDGLG))
!  Define distribution of vertical normal modes

!  Temporary allocation of over-dimensioned array for the
!  distribution of vertical normal modes. Both NMI and Jb are 
!  considered. The same distribution is used for NMI and Jb, 
!  so only one table (NVMODIST) is needed, together with the
!  counters NVMODJBPP and NVMODPP.

LLDONMI=NEINI /= 0.AND.NEINI /= 2
LLVAR=NCONF/100 /= 0.AND.NCONF/100 /= 2
IF (LLDONMI) THEN
  INVMODMX=MAX(NVMOD,NVMODJB)
  ALLOCATE (INVMODIST(INVMODMX,NPRTRV))
  IF (LALLOPR) WRITE(NULOUT,9990) 'INVMODIST',SIZE(INVMODIST),&
   & SHAPE(INVMODIST)  

  NUMVMO(:)=0
  IF (LLVAR) NUMVMOJB(:)=0
  NVMODPP = 0
  NVMODJBPP = 0

  INVMODIST(:,:)=-999
  IIC(:)  = 1
  IND = 1
  IK  = 0
  DO JNMODE=1,INVMODMX
    IK = IK + IND
    IF (IK > NPRTRV) THEN
      IK = NPRTRV
      IND = -1
    ELSEIF (IK < 1) THEN
      IK = 1
      IND = 1
    ENDIF
    IF (JNMODE <= NVMOD) NUMVMO(IK)=NUMVMO(IK)+1
    IF (LLVAR.AND.JNMODE <= NVMODJB) NUMVMOJB(IK)=NUMVMOJB(IK)+1
    INVMODIST(IIC(IK),IK) = JNMODE
    IIC(IK) = IIC(IK)+1
  ENDDO
  IF (LLVAR) NVMODJBPP = NUMVMOJB(MYSETV)
  NVMODPP = NUMVMO(MYSETV)
ENDIF

! Define local definitions for this processor set

NSPEC2V=NPTRSV(MYSETV+1)-NPTRSV(MYSETV)
NCPEC2V=NPTRCV(MYSETV+1)-NPTRCV(MYSETV)
NTPEC2V=NPTRTV(MYSETV+1)-NPTRTV(MYSETV)
NSPEC2VF=NPTRSVF(MYSETV+1)-NPTRSVF(MYSETV)

!  Adjust NPROMA to optimise for memory usage and vector length
!  Only do this if LOPTPROMA is true

IF (LOPTPROMA) THEN
!   Allow nproma to drift upwards by up to 5 percent if this results
!   in a reduction of the number of grid point blocks
  ITHRMAX=OML_MAX_THREADS()
  IF( ITHRMAX > 1 )THEN
!  Optimise NPROMA for maximum number of threads
    IPROMA=NPROMA*1.05
    NPROMA=(NGPTOTMX-1)/ITHRMAX+1
    I=1
    DO WHILE( NPROMA > IPROMA )
      I=I+1
      NPROMA=(NGPTOTMX-1)/(ITHRMAX*I)+1
    ENDDO
! Check if we have enough blocks to switch to a more optimal nproma
! i.e. more than 10 blocks per thread (for scalar only)
    IGPBLKSMX=(NGPTOTMX-1)/NPROMA+1
    IF( LOPT_SCALAR )THEN
      IF( IGPBLKSMX/ITHRMAX > 10 )THEN
        IF( NFLEVG <= 62 )THEN
          NPROMA=56
        ELSEIF( NFLEVG <= 91 )THEN
          NPROMA=32
        ELSE
          NPROMA=24
        ENDIF
      ENDIF
    ENDIF
  ELSE
    IPROMABEG=NPROMA+1
    IPROMAEND=IPROMABEG+NPROMA*5/100
    IGPBLKSMX=(NGPTOTMX-1)/NPROMA+1
    NPROMA=(NGPTOTMX-1)/IGPBLKSMX+1
    DO JJ=IPROMABEG,IPROMAEND
      IMX=(NGPTOTMX-1)/JJ+1
      IPR=(NGPTOTMX-1)/IMX+1
      IF (IMX < IGPBLKSMX) THEN
        IGPBLKSMX=IMX
        NPROMA=IPR
      ENDIF
    ENDDO
  ENDIF

  IF (LOUTPUT) WRITE(NULOUT,'("SUMP: NPROMA OPTIMISED =",I6)') NPROMA
  IF( NPROMM > 0)THEN
    NPROMM=NPROMA
    IF (LOUTPUT) WRITE(NULOUT,'("SUMP: NPROMM OPTIMISED =",I6)') NPROMM
  ENDIF
  IF( NPROMT > 0)THEN
    NPROMT=NPROMA
    IF (LOUTPUT) WRITE(NULOUT,'("SUMP: NPROMT OPTIMISED =",I6)') NPROMT
  ENDIF
  IF( NPROMNH > 1)THEN
    NPROMNH=NPROMA
    IF (LOUTPUT) WRITE(NULOUT,'("SUMP: NPROMNH OPTIMISED =",I6)') NPROMNH
  ENDIF
  IF( NPROMVC > 1)THEN
    NPROMVC=NPROMA
    IF (LOUTPUT) WRITE(NULOUT,'("SUMP: NPROMVC OPTIMISED =",I6)') NPROMVC
  ENDIF
  IF( NPROMDLW > 1)THEN
    NPROMDLW=NPROMA
    IF (LOUTPUT) WRITE(NULOUT,'("SUMP: NPROMDLW OPTIMISED =",I6)') NPROMDLW
  ENDIF
  IF( NPROMDLR > 1)THEN
    NPROMDLR=NPROMA
    IF (LOUTPUT) WRITE(NULOUT,'("SUMP: NPROMDLR OPTIMISED =",I6)') NPROMDLR
  ENDIF
  IF( NPROMDLR2 > 1)THEN
    NPROMDLR2=NPROMA
    IF (LOUTPUT) WRITE(NULOUT,'("SUMP: NPROMDLR2 OPTIMISED =",I6)') NPROMDLR2
  ENDIF
  IF( NPROMDLG > 1)THEN
    NPROMDLG=NPROMA
    IF (LOUTPUT) WRITE(NULOUT,'("SUMP: NPROMDLG OPTIMISED =",I6)') NPROMDLG
  ENDIF
ENDIF

!  Calculate number of NPROMA-blocks of grid point data

NGPBLKS=(NGPTOT-1)/NPROMA+1

!  There are no capping points in the global model gridpoint domain

NGPTOT_CAP=NGPTOT

! * Test that NPROMA=NGPTOTMX when using option LWRTCFOU with DM.
IF (LWRTCFOU.AND.(NPROMA /= NGPTOTMX)) THEN
  WRITE(NULERR,'(1X,A,A)') ' SUMP: when LWRTCFOU=T ',&
   & ' NPROMA must be equal to NGPTOTMX.'  
  WRITE(NULERR,'(1X,A,I7)') '       Relaunch job with NPROMA=',NGPTOTMX
  CALL ABOR1(' SUMP: ABOR1 CALLED')
ENDIF

!  Allocate more pointer arrays that depend on distributed dimensions

CALL SUALMP2

! Actual wave numbers handled by this processor
DO JMLOC=1,NUMCP
  MYMS(JMLOC)=IMYMS(JMLOC)
ENDDO

!  Setup distributed spectral field type

CALL SETUP_SPEC(nprtrv,nprtrw,mysetv,mysetw,nflevl,nflevg,numcp,myms, &
 & nsmax,nmsmax,nallms,nptrms,numll,nptrll,npsurf,lelam, &
 & NULOUT,NGRBVO,NGRBD,NGRBT,NGRBQ,NGRBO3,NGRBLNSP)  

! Mapping between physical latitude number and local latitude number

ISTAL=NDGSAL
IENDL=NDGENL
DO JLT=ISTAL,IENDL
  MYLATS(JLT) = NFRSTLAT(MY_REGION_NS)+JLT-NDGSAL
ENDDO

IF (LLDONMI) THEN
  IF (LLVAR) THEN
    INVMODMXPP=MAX(MAXVAL(NUMVMO),MAXVAL(NUMVMOJB))
  ELSE
    INVMODMXPP=MAXVAL(NUMVMO)
  ENDIF
  NVMODIST(1:INVMODMXPP,:)=INVMODIST(1:INVMODMXPP,:)
  DEALLOCATE(INVMODIST)
  IF (LALLOPR) WRITE(NULOUT,9991) 'INVMODIST'
  9991 FORMAT(1X,'ARRAY ',A10,' DEALLOCATED ')
ENDIF

! Mapping of local grid points to global grid points for debugging

I=0
IGLOBAL(:,:)=0
DO JGL=1,NDGLG
  DO JL=1,NLOENG(JGL)
    I=I+1
    IGLOBAL(JL,JGL) = I
  ENDDO
ENDDO
I=0
DO JGL=NFRSTLAT(MY_REGION_NS),NLSTLAT(MY_REGION_NS)
  IGL = NPTRFRSTLAT(MY_REGION_NS)+JGL-NFRSTLAT(MY_REGION_NS)
  DO JL=NSTA(IGL,MY_REGION_EW),NSTA(IGL,MY_REGION_EW)+NONL(IGL,MY_REGION_EW)-1
    I=I+1
    IF( IGLOBAL(JL,JGL) == 0 )THEN
      CALL ABOR1('SUMP: INTERNAL ERROR, INVALID GLOBAL INDEX')
    ENDIF
    NGLOBALINDEX(I)=IGLOBAL(JL,JGL)
  ENDDO
ENDDO

! Initialise NGLOBALPROC, NLOCALINDEX

NGLOBALPROC(:)=0
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JA,JB,IPROC,I,JGL,IGL,JL,IND)
DO JA=1,N_REGIONS_NS
  DO JB=1,N_REGIONS(JA)
    IPROC=NGPSET2PE(JA,JB)
    I=0
    DO JGL=NFRSTLAT(JA),NLSTLAT(JA)
      IGL = NPTRFRSTLAT(JA)+JGL-NFRSTLAT(JA)
      DO JL=NSTA(IGL,JB),NSTA(IGL,JB)+NONL(IGL,JB)-1
        IND=IGLOBAL(JL,JGL)
        NGLOBALPROC(IND)=IPROC
        I=I+1
        NLOCALINDEX(IND)=I
      ENDDO
    ENDDO
  ENDDO
ENDDO
!$OMP END PARALLEL DO

!DO JL=1,NGPTOTG
!  WRITE(NULOUT,'("SUMP: JL,NGLOBALPROC,NLOCALINDEX=",3(2X,I10))')&
!   &JL,NGLOBALPROC(JL),NLOCALINDEX(JL)
!ENDDO

IF (LOUTPUT) THEN
  WRITE(NULOUT,'(/'' OUTPUT FROM ROUTINE SUMP - PART 2:''/)')
  WRITE(NULOUT,'('' NGPBLKS ='',I8)') NGPBLKS
ENDIF
IF (LOUTPUT.AND.NPRINTLEV >= 1) THEN
  WRITE(NULOUT,'('' MYMS '')')
  WRITE(NULOUT,'(30(1X,I3))')(MYMS(JJ),JJ=1,NUMP)
  WRITE(NULOUT,'('' NALLMS '')')
  WRITE(NULOUT,'(30(1X,I3))')(NALLMS(JJ),JJ=1,NSMAX+1)
  WRITE(NULOUT,'('' NPTRMS '')')
  WRITE(NULOUT,'(20(1X,I4))')(NPTRMS(JJ),JJ=1,NPRTRW)
  WRITE(NULOUT,'('' NPOSSP '')')
  WRITE(NULOUT,'(20(1X,I8))')(NPOSSP(JJ),JJ=1,NPRTRW)
  WRITE(NULOUT,'('' NASM0 '')')
  WRITE(NULOUT,'(16(1X,I6))')(NASM0(JJ),JJ=0,NSMAX)
  WRITE(NULOUT,'('' NACM0 '')')
  WRITE(NULOUT,'(16(1X,I6))')(NACM0(JJ),JJ=0,NCMAX)
  WRITE(NULOUT,'('' NATM0 '')')
  WRITE(NULOUT,'(16(1X,I6))')(NATM0(JJ),JJ=0,NTMAX)
  WRITE(NULOUT,'('' NDIM0G '')')
  WRITE(NULOUT,'(16(1X,I6))')(NDIM0G(JJ),JJ=0,NSMAX)
  WRITE(NULOUT,'('' NSPEC, NSPEC2, NSPEC2MX, NSPEC2V, NSPEC2VF'')')
  WRITE(NULOUT,'(5(1X,I6))')NSPEC, NSPEC2, NSPEC2MX, NSPEC2V,NSPEC2VF
  WRITE(NULOUT,'('' NTPEC2, NTPEC2V, NCPEC, NCPEC2, NCPEC2V'')')
  WRITE(NULOUT,'(5(1X,I6))')NTPEC2, NTPEC2V, NCPEC,NCPEC2, NCPEC2V
  WRITE(NULOUT,'('' NDGLL,NDGSAL,NDGENL '')')
  WRITE(NULOUT,'(1X,3I4)') NDGLL, NDGSAL, NDGENL
  WRITE(NULOUT,'('' NDGLG,NDGSAG,NDGENG '')')
  WRITE(NULOUT,'(1X,3I4)') NDGLG, NDGSAG, NDGENG
  WRITE(NULOUT,'('' MYFRSTACTLAT, MYLSTACTLAT '')')
  WRITE(NULOUT,'(1X,2I4)') MYFRSTACTLAT, MYLSTACTLAT
  WRITE(NULOUT,'('' NPTRLS '')')
  WRITE(NULOUT,'(20(1X,I4))')(NPTRLS(JJ),JJ=1,NPRTRW)

  WRITE(NULOUT,'('' NPTRSV '')')
  WRITE(NULOUT,'(16(1X,I6))')(NPTRCV(JJ),JJ=1,NPRTRV+1)
  WRITE(NULOUT,'('' NPTRCV '')')
  WRITE(NULOUT,'(16(1X,I6))')(NPTRSV(JJ),JJ=1,NPRTRV+1)
  WRITE(NULOUT,'('' NPTRTV '')')
  WRITE(NULOUT,'(16(1X,I6))')(NPTRTV(JJ),JJ=1,NPRTRV+1)
  WRITE(NULOUT,'('' NPTRSVF '')')
  WRITE(NULOUT,'(16(1X,I6))')(NPTRSVF(JJ),JJ=1,NPRTRV+1)
  WRITE(NULOUT,'('' NPTRMF '')')
  WRITE(NULOUT,'(16(1X,I6))')(NPTRMF(JJ),JJ=1,NPRTRV+1)
  WRITE(NULOUT,'('' NSPSTAF-VALUES FOR THE M-WAVES USED '')')
  WRITE(NULOUT,'(6(1x,''('',I4,I6,'')''))') (MYMS(JMLOC),&
   & NSPSTAF(MYMS(JMLOC)),JMLOC=NPTRMF(MYSETV),NPTRMF(MYSETV+1)-1)  
  WRITE(NULOUT,'('' MYLEVS '')')
  WRITE(NULOUT,'(20(1X,I4))') (MYLEVS(JJ),JJ=1,NFLEVL)
  WRITE(NULOUT,'('' NUMLL '')')
  WRITE(NULOUT,'(20(1X,I4))')(NUMLL(JJ),JJ=1,NPRTRV+1)

  IF (LLDONMI) THEN
    WRITE(NULOUT,'('' NUMVMO '')')
    WRITE(NULOUT,'(20(1X,I4))')(NUMVMO(JJ),JJ=1,NPRTRV)
    IF (LLVAR) THEN
      WRITE(NULOUT,'('' NUMVMOJB '')')
      WRITE(NULOUT,'(20(1X,I4))')(NUMVMOJB(JJ),JJ=1,NPRTRV)
      WRITE(NULOUT,'('' NVMODJBPP '')')
      WRITE(NULOUT,'(1X,I6)')NVMODJBPP
    ENDIF
    WRITE(NULOUT,'('' NVMODPP NBSETSP '')')
    WRITE(NULOUT,'(1X,2I6)')NVMODPP, NBSETSP
    DO JBSET=1,NPRTRV
      WRITE(NULOUT,'('' NVMODIST FOR B-SET NUMBER '',I3)') JBSET
      IF (LLVAR) THEN
        IIMX=MAX(NUMVMO(JBSET),NUMVMOJB(JBSET))
      ELSE
        IIMX=NUMVMO(JBSET)
      ENDIF
      WRITE(NULOUT,'(20(1X,I4))')(NVMODIST(1:IIMX,JBSET))
    ENDDO
  ENDIF
  WRITE(NULOUT,'('' NPTRLL '')')
  WRITE(NULOUT,'(20(1X,I4))')(NPTRLL(JJ),JJ=1,NPRTRV+1)
  WRITE(NULOUT,'('' NBSETLEV '')')
  WRITE(NULOUT,'(20(1X,I4))')(NBSETLEV(JJ),JJ=1,NFLEVG)
  WRITE(NULOUT,'('' MYLATS '')')
  WRITE(NULOUT,'(20(1X,I4))') (MYLATS(JJ),JJ=ISTAL,IENDL)
ENDIF
IF (LOUTPUT) THEN
  WRITE(UNIT=NULOUT,FMT='('' NGPTOT NGPTOTMX NGPTOTG NGPTOT_CAP '')')
  WRITE(UNIT=NULOUT,FMT='(4(1X,I7))') NGPTOT, NGPTOTMX, NGPTOTG, NGPTOT_CAP
ENDIF

9990 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8)

!     ------------------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('SUMP',1,ZHOOK_HANDLE)
END SUBROUTINE SUMP
