sustaonl_mod.F90

Go to the documentation of this file.

MODULE sustaonl_mod
CONTAINS
SUBROUTINE sustaonl(KMEDIAP,KRESTM)

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

!     Purpose.
!     --------
!           Initialize D%NSTA and D%NONL.
!           Calculation of distribution of grid points to processors :
!           Splitting of grid in B direction

!**   Interface.
!     ----------
!        *CALL* *SUSTAONL *

!        Explicit arguments : KMEDIAP - mean number of grid points per PE
!        -------------------- KRESTM  - number of PEs with one extra point

!        Implicit arguments :
!        --------------------


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

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

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

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

!     Modifications.
!     --------------
!        Original : 95-10-01
!        Modified 98-08-10 by K. YESSAD: removal of LRPOLE option.
!          - removal of LRPOLE in YOMCT0.
!          - removal of code under LRPOLE.
!        Modified 98-12-04 C. Fischer: merge with SUESTAONL (Aladin)
!     ------------------------------------------------------------------

USE parkind1  ,ONLY : jpim     ,jprb
!USE MPL_MODULE      ! MPL 4.12.08

USE tpm_gen
USE tpm_dim
USE tpm_geometry
USE tpm_distr

USE set2pe_mod
USE abort_trans_mod
USE eq_regions_mod

IMPLICIT NONE


!     DUMMY 
INTEGER(KIND=JPIM),INTENT(IN) :: KMEDIAP
INTEGER(KIND=JPIM),INTENT(IN) :: KRESTM

!     LOCAL

INTEGER(KIND=JPIM) :: IXPTLAT(r%ndgl), ILSTPTLAT(r%ndgl)
INTEGER(KIND=JPIM) :: ICHK(r%ndlon,r%ndgl), ICOMBUF(r%ndgl*n_regions_ew*2)
INTEGER(KIND=JPIM) :: I1, I2, IBUFLEN, IDGLG, IDWIDE,&
             &IGL, IGL1, IGL2, IGLOFF, IGPTA, IGPTOT, &
             &IGPTPRSETS, IGPTS, IGPTSP, ILEN, ILRECV, &
             &ILSEND, INPLAT, INXLAT, IPART,  IPOS, &
             &IPROCB, IPTSRE, IRECV, IPE, &
             &IREST, ISEND, ITAG, JA, JB, JGL, JL, JNPTSRE

LOGICAL :: LLABORT, LLALLAT
LOGICAL :: LLP1,LLP2

REAL(KIND=JPRB) ::  ZLAT, ZLAT1
REAL(KIND=JPRB) :: ZDIVID(r%ndgl),ZXPTLAT(r%ndgl)

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

llp1 = nprintlev>0
llp2 = nprintlev>1

idwide  = r%NDGL/2
ibuflen = r%NDGL*n_regions_ew*2
idglg   = r%NDGL

i1 = max(   1,d%NFRSTLAT(my_region_ns)-d%NFRSTLOFF)
i2 = min(idglg,d%NLSTLAT (my_region_ns)-d%NFRSTLOFF)

ilen = d%NLSTLAT(my_region_ns) - d%NFRSTLAT(my_region_ns)+1

igptprsets = sum(g%NLOEN(1:d%NFRSTLAT(my_region_ns)-1))

igptot = sum(g%NLOEN(1:r%NDGL))

IF (d%LSPLIT) THEN
  IF( leq_regions )THEN
    ipe=0
    igpta=0
    DO ja=1,my_region_ns-1
      DO jb=1,n_regions(ja)
        ipe=ipe+1
        IF( ipe <= krestm .OR. krestm  ==  0)THEN
          igpta  = igpta + kmediap
        ELSE
          igpta  = igpta + (kmediap-1)
        ENDIF
      ENDDO
    ENDDO
    igpts=0
    DO jb=1,n_regions(my_region_ns)
      ipe=ipe+1
      IF( ipe <= krestm .OR. krestm  ==  0 )THEN
        igpts = igpts + kmediap
      ELSE
        igpts = igpts + (kmediap-1)
      ENDIF
    ENDDO
  ELSE
    IF (my_region_ns <= krestm.OR.krestm == 0) THEN
      igpts = kmediap
      igpta = kmediap*(my_region_ns-1)
    ELSE
      igpts = kmediap-1
      igpta = kmediap*krestm+igpts*(my_region_ns-1-krestm)
    ENDIF
  ENDIF
ELSE
  igpta = igptprsets
  igpts = sum(g%NLOEN(d%NFRSTLAT(my_region_ns):d%NLSTLAT(my_region_ns)))
ENDIF

igptsp = igpts/n_regions(my_region_ns)
irest = igpts-n_regions(my_region_ns)*igptsp
ixptlat(1) = igpta-igptprsets+1
zxptlat(1) = REAL(ixptlat(1))
ilstptlat(1) = g%NLOEN(d%NFRSTLAT(my_region_ns))
inplat = g%NLOEN(d%NFRSTLAT(my_region_ns))-ixptlat(1)+1
DO jgl=2,ilen
  ixptlat(jgl) = 1
  zxptlat(jgl) = 1.0_jprb
  ilstptlat(jgl) =  g%NLOEN(d%NFRSTLAT(my_region_ns)+jgl-1)
  inplat = inplat+g%NLOEN(d%NFRSTLAT(my_region_ns)+jgl-1)
ENDDO
ilstptlat(ilen) = g%NLOEN(d%NLSTLAT(my_region_ns))-inplat+igpts

DO jb=1,n_regions_ew
  DO jgl=1,r%NDGL+n_regions_ns-1
    d%NSTA(jgl,jb) = 0
    d%NONL(jgl,jb) = 0
  ENDDO
ENDDO


!  grid point decomposition
!  ---------------------------------------
llallat = (n_regions_ns == 1)
DO jgl=1,ilen
  zdivid(jgl)=REAL(G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1),JPRB)
ENDDO
DO jb=1,n_regions(my_region_ns)

  IF (jb <= irest) THEN
    iptsre = igptsp+1
  ELSE
    iptsre = igptsp
  ENDIF

  ipart=0
  DO jnptsre=1,iptsre
    zlat  = 1._jprb
    zlat1 = 1._jprb
    IF (my_region_ns <= d%NAPSETS .AND.(ipart /= 2.OR.llallat)) THEN
!cdir novector
      DO jgl=1,ilen
        IF (ixptlat(jgl)  <=  ilstptlat(jgl)) THEN
          zlat1  = (zxptlat(jgl)-1.0_jprb)/zdivid(jgl)
          zlat   = min(zlat1,zlat)
          inxlat = jgl
          ipart  = 1
          EXIT
        ENDIF
      ENDDO
    ELSEIF (my_region_ns > n_regions_ns-d%NAPSETS.AND.(ipart /= 1.OR.llallat)) THEN
!cdir novector
      DO jgl=1,ilen
        IF (ixptlat(jgl)  <=  ilstptlat(jgl)) THEN
          zlat1  = (zxptlat(jgl)-1.0_jprb)/zdivid(jgl)
          zlat   = min(zlat1,zlat)
          inxlat = jgl
          ipart  = 2
          EXIT
        ENDIF
      ENDDO
    ELSE
!cdir novector
      DO jgl=1,ilen
        IF (ixptlat(jgl)  <=  ilstptlat(jgl)) THEN
          zlat1 = (zxptlat(jgl)-1.0_jprb)/zdivid(jgl)
          IF (zlat1 < zlat) THEN
            zlat   = zlat1
            inxlat = jgl
          ENDIF
        ENDIF
      ENDDO
    ENDIF

    IF (inxlat >= i1 .AND. inxlat <= i2) THEN
      IF (d%NSTA(d%NPTRFLOFF+inxlat,jb) == 0) THEN
        d%NSTA(d%NPTRFLOFF+inxlat,jb) = ixptlat(inxlat)
      ENDIF
      d%NONL(d%NPTRFLOFF+inxlat,jb) = d%NONL(d%NPTRFLOFF+inxlat,jb)+1
    ENDIF
    ixptlat(inxlat) = ixptlat(inxlat)+1
    zxptlat(inxlat) = REAL(IXPTLAT(INXLAT),JPRB)
  ENDDO
ENDDO


! Exchange local partitioning info to produce global view
!

IF( nproc > 1 )THEN

  IF( leq_regions )THEN

    itag = mtagpart
    ipos = 0
    DO jgl=1,d%NLSTLAT(my_region_ns)-d%NFRSTLAT(my_region_ns)+1
      ipos = ipos+1
      icombuf(ipos) = d%NSTA(d%NPTRFLOFF+jgl,my_region_ew)
      ipos = ipos+1
      icombuf(ipos) = d%NONL(d%NPTRFLOFF+jgl,my_region_ew)
    ENDDO
    IF( ipos > ibuflen )THEN
      CALL abort_trans(' SUSTAONL: SEND BUFFER TOO SMALL FOR GLOBAL INFO')
    ENDIF
    ilsend = ipos

    DO ja=1,n_regions_ns
      DO jb=1,n_regions(ja)
        CALL set2pe(isend,ja,jb,0,0)
        IF(isend /= myproc) THEN
!         CALL MPL_SEND(ICOMBUF(1:ILSEND),KDEST=NPRCIDS(ISEND),KTAG=ITAG, &
!          &   CDSTRING='SUSTAONL:')
!         MPL 4.12.08
          CALL abor1(' SUSTAONL: JUSTE APRES MPL_SEND')
        ENDIF
      ENDDO
    ENDDO

    DO ja=1,n_regions_ns
      igl1 = d%NFRSTLAT(ja)
      igl2 = d%NLSTLAT(ja)
      DO jb=1,n_regions(ja)
        CALL set2pe(irecv,ja,jb,0,0)
        IF(irecv /= myproc) THEN
          ilen = (d%NLSTLAT(ja)-d%NFRSTLAT(ja)+1)*2
!         CALL MPL_RECV(ICOMBUF(1:ILEN),KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, &
!          & KOUNT=ILRECV,CDSTRING='SUSTAONL:')
!         MPL 4.12.08
          CALL abor1(' SUSTAONL: JUSTE APRES MPL_RCV')
          ipos = 0
          DO jgl=igl1,igl2
            igl = d%NPTRFRSTLAT(ja)+jgl-igl1
            ipos = ipos+1
            d%NSTA(igl,jb) = icombuf(ipos)
            ipos = ipos+1
            d%NONL(igl,jb) = icombuf(ipos)
          ENDDO
        ENDIF
      ENDDO
    ENDDO

  ELSE

    itag = mtagpart
    ipos = 0
    DO jb=1,n_regions(my_region_ns)
      DO jgl=1,d%NLSTLAT(my_region_ns)-d%NFRSTLAT(my_region_ns)+1
        ipos = ipos+1
        icombuf(ipos) = d%NSTA(d%NPTRFLOFF+jgl,jb)
        ipos = ipos+1
        icombuf(ipos) = d%NONL(d%NPTRFLOFF+jgl,jb)
      ENDDO
    ENDDO
    IF( ipos > ibuflen )THEN
      CALL abort_trans(' SUSTAONL: SEND BUFFER TOO SMALL FOR GLOBAL INFO')
    ENDIF
    ilsend = ipos
    DO ja=1,n_regions_ns
      CALL set2pe(isend,ja,my_region_ew,0,0)
      IF(isend /= myproc) THEN
!       CALL MPL_SEND(ICOMBUF(1:ILSEND),KDEST=NPRCIDS(ISEND),KTAG=ITAG, &
!        &   CDSTRING='SUSTAONL:')
!         MPL 4.12.08
          CALL abor1(' SUSTAONL: JUSTE APRES MPL_SEND')
      ENDIF
    ENDDO

    DO ja=1,n_regions_ns
      CALL set2pe(irecv,ja,my_region_ew,0,0)
      IF(irecv /= myproc) THEN
        ilen = (d%NLSTLAT(ja)-d%NFRSTLAT(ja)+1)*n_regions(ja)*2
!       CALL MPL_RECV(ICOMBUF(1:ILEN),KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, &
!        & KOUNT=ILRECV,CDSTRING='SUSTAONL:')
!         MPL 4.12.08
          CALL abor1(' SUSTAONL: JUSTE APRES MPL_RCV')
        igl1 = d%NFRSTLAT(ja)
        igl2 = d%NLSTLAT(ja)
        ipos = 0
        DO jb=1,n_regions(ja)
          DO jgl=igl1,igl2
            igl = d%NPTRFRSTLAT(ja)+jgl-igl1
            ipos = ipos+1
            d%NSTA(igl,jb) = icombuf(ipos)
            ipos = ipos+1
            d%NONL(igl,jb) = icombuf(ipos)
          ENDDO
        ENDDO
      ENDIF
    ENDDO

  ENDIF

ENDIF

! Confirm consistency of global partitioning, specifically testing for
! multiple assignments of same grid point and unassigned grid points

llabort = .false.
DO jgl=1,r%NDGL
  DO jl=1,g%NLOEN(jgl)
    ichk(jl,jgl) = 1
  ENDDO
ENDDO
DO ja=1,n_regions_ns
  igloff = d%NPTRFRSTLAT(ja)
  DO jb=1,n_regions(ja)
    igl1 = d%NFRSTLAT(ja)
    igl2 = d%NLSTLAT(ja)
    DO jgl=igl1,igl2
      igl = igloff+jgl-igl1
      DO jl=d%NSTA(igl,jb),d%NSTA(igl,jb)+d%NONL(igl,jb)-1
        IF( ichk(jl,jgl) /= 1 )THEN
          WRITE(nout,'(" SUSTAONL : seta=",i4," setb=",i4,&
           &" row=",I4," sta=",I4," INVALID GRID POINT")')&
           &ja,jb,jgl,jl
          WRITE(0,'(" SUSTAONL : seta=",i4," setb=",i4,&
           &" ROW=",I4," sta=",I4," INVALID GRID POINT")')&
           &ja,jb,jgl,jl
          llabort = .true.
        ENDIF
        ichk(jl,jgl) = 2
      ENDDO
    ENDDO
  ENDDO
ENDDO
DO jgl=1,r%NDGL
  DO jl=1,g%NLOEN(jgl)
    IF( ichk(jl,jgl) /= 2 )THEN
      WRITE(nout,'(" SUSTAONL : row=",i4," sta=",i4,&
       &" GRID POINT NOT ASSIGNED")') jgl,jl
      llabort = .true.
    ENDIF
  ENDDO
ENDDO
IF( llabort )THEN
  WRITE(nout,'(" SUSTAONL : inconsistent partitioning")')
  CALL abort_trans(' SUSTAONL: inconsistent partitioning')
ENDIF


IF (llp1) THEN
  WRITE(unit=nout,fmt='('' OUTPUT FROM ROUTINE SUSTAONL '')')
  WRITE(unit=nout,fmt='('' '')')
  WRITE(unit=nout,fmt='('' PARTITIONING INFORMATION '')')
  WRITE(unit=nout,fmt='('' '')')
  iprocb = min(32,n_regions_ew)
  WRITE(unit=nout,fmt='(17X," SETB=",32(1X,I3))') (jb,jb=1,iprocb)
  DO ja=1,n_regions_ns
    iprocb = min(32,n_regions(ja))
    WRITE(unit=nout,fmt='('' '')')
    igloff = d%NPTRFRSTLAT(ja)
    igl1 = d%NFRSTLAT(ja)
    igl2 = d%NLSTLAT(ja)
    DO jgl=igl1,igl2
      igl=igloff+jgl-igl1
      WRITE(unit=nout,fmt='(" SETA=",I3," LAT=",I3," NSTA=",&
       &32(1X,I3))') ja,jgl,(d%NSTA(igl,jb),jb=1,iprocb)
      WRITE(unit=nout,fmt='(" SETA=",I3," LAT=",I3," D%NONL=",&
       &32(1X,I3))') ja,jgl,(d%NONL(igl,jb),jb=1,iprocb)
      WRITE(unit=nout,fmt='('' '')')
    ENDDO
    WRITE(unit=nout,fmt='('' '')')
  ENDDO
  WRITE(unit=nout,fmt='('' '')')
  WRITE(unit=nout,fmt='('' '')')
ENDIF

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

END SUBROUTINE sustaonl
END MODULE sustaonl_mod