sutrle_mod.F90

Go to the documentation of this file.

MODULE sutrle_mod
CONTAINS
SUBROUTINE sutrle(PNM)

!**** *sutrle * - transposition of Legendre polynomials during set-up

!     Purpose.
!     --------
!           transposition of Legendre polynomials during set-up

!**   Interface.
!     ----------
!        *call* *sutrle(pnm)

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

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

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

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

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

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

!     Modifications.
!     --------------
!        Original : 95-10-01
!     ------------------------------------------------------------------


USE parkind1  ,ONLY : jpim     ,jprb
!USE MPL_MODULE

USE tpm_gen
USE tpm_dim
USE tpm_distr
USE tpm_fields
USE set2pe_mod
USE abort_trans_mod

IMPLICIT NONE

REAL(KIND=JPRB),INTENT(IN) :: PNM(r%nspoleg,d%nlei3d)

!     LOCAL 

REAL(KIND=JPRB), ALLOCATABLE :: ZCOMBUF(:)
REAL(KIND=JPRB), POINTER     :: ZPNM(:,:)
INTEGER(KIND=JPIM) :: IGLLOC, ILREC, IM, INENTR, IPOS, &
             &IRECSET, IRECV, ISEND, ISENDSET, ITAG, &
             &JGL, JGLLOC, JM, JMLOC, JN, JROC ,IOFFT, IOFFG

LOGICAL :: LLADMSG, LLEXACT

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

!*       0.    Some initializations.
!              ---------------------
!! Workaround for obscure unwillingness to vectorize on VPP
zpnm => f%RPNM

! Perform barrier synchronisation to guarantee all processors have
! completed all previous communication

IF( nproc > 1 )THEN
! CALL GSTATS(783,0)     ! MPL 3.12.08
! CALL MPL_BARRIER(CDSTRING='SUTRLE:')
! CALL GSTATS(783,1)
  CALL abor1(' SUTRLE:A LA PLACE DE MPL_BARRIER')
ENDIF

ALLOCATE (zcombuf(ncombflen))

DO jroc=1,nprtrw-1

  lladmsg = .false.
  itag = mtagletr

!*     Define PE to which data have to be sent and PE from which
!*     data have to be received

! CALL GSTATS(801,0)  ! MPL 4.12.08
  isend = mysetw-jroc
  irecv = mysetw+jroc
  IF (isend <= 0)     isend = isend+nprtrw
  IF (irecv > nprtrw) irecv = irecv-nprtrw
  irecset = irecv
  isendset = isend
  CALL set2pe(isend,0,0,isend,mysetv)
  CALL set2pe(irecv,0,0,irecv,mysetv)

!*   copy data to be sent into zcombuf

  ipos = 0
  DO jm=0,r%NSMAX
    IF (isendset == d%NPROCM(jm)) THEN
      inentr = (d%NLATLE(mysetw)-d%NLATLS(mysetw)+1)*(r%NTMAX-jm+2)
      IF (ipos + inentr < ncombflen) THEN
        DO jgl=d%NLATLS(mysetw),d%NLATLE(mysetw)
          jglloc = jgl - d%NLATLS(mysetw) + 1
          DO jn=1,r%NTMAX-jm+2
            ipos = ipos + 1
            zcombuf(ipos) = pnm(d%NPMG(jm)+jn,jglloc)
          ENDDO
        ENDDO
      ELSE
        DO jgl=d%NLATLS(mysetw),d%NLATLE(mysetw)
          jglloc = jgl - d%NLATLS(mysetw) + 1
          DO jn=1,r%NTMAX-jm+2
            ipos = ipos + 1
            zcombuf(ipos) = pnm(d%NPMG(jm)+jn,jglloc)
            IF (ipos == ncombflen) THEN
!             CALL MPL_SEND(zcombuf(1:ipos),KDEST=NPRCIDS(ISEND), &
!              & KTAG=ITAG,CDSTRING='SUTRLE:')     ! MPL 3.12.08
              CALL abor1(' SUTRLE:A LA PLACE DE MPL_SEND')
              ipos = 0
              itag = itag + 1
              llexact = (jgl == d%NLATLE(mysetw) .AND. jn == r%NTMAX-jm+2)
              IF (.NOT.llexact) lladmsg = .true.
            ENDIF
          ENDDO
        ENDDO
      ENDIF
    ENDIF
  ENDDO

!*   send message (if not empty or if message has been split)

  IF (ipos > 0 .OR. lladmsg) THEN
!   CALL MPL_SEND(ZCOMBUF(1:IPOS),KDEST=NPRCIDS(ISEND), &
!    & KTAG=ITAG,CDSTRING='SUTRLE:')    ! MPL 3.12.08
     CALL abor1(' SUTRLE:A LA PLACE DE MPL_SEND')
  ENDIF
! CALL GSTATS(801,1) ! MPL 4.12.08

  ilrec = 0
  itag = mtagletr
  IF (d%NUMP > 0.AND. d%NLATLE(irecset) >= d%NLATLS(irecset)) THEN

!*   receive message (if not empty)

!   CALL GSTATS(801,0)
!   CALL MPL_RECV(ZCOMBUF(1:NCOMBFLEN),KSOURCE=NPRCIDS(IRECV), &
!    & KTAG=ITAG,KOUNT=ILREC,CDSTRING='SUTRLE:')  ! MPL 3.12.08
    CALL abor1(' SUTRLE:A LA PLACE DE MPL_RECV')

!*   copy data from buffer to f%rpnm

    ipos = 0
    DO jmloc=1,d%NUMP
      jm = d%MYMS(jmloc)
      inentr = (d%NLATLE(irecset)-d%NLATLS(irecset)+1)*(r%NTMAX-jm+2)
      iofft = d%NPMT(jm) 
      IF (ipos + inentr < ncombflen) THEN
        DO jgl=d%NLATLS(irecset),d%NLATLE(irecset)
          DO jn=1,r%NTMAX-jm+2
            ipos = ipos + 1
            zpnm(jgl,iofft+jn) = zcombuf(ipos)
          ENDDO
        ENDDO
      ELSE
        DO jgl=d%NLATLS(irecset),d%NLATLE(irecset)
          DO jn=1,r%NTMAX-jm+2
            ipos = ipos + 1
            zpnm(jgl,iofft+jn) = zcombuf(ipos)
            IF (ipos == ncombflen) THEN
              itag = itag + 1
!             CALL MPL_RECV(ZCOMBUF(1:NCOMBFLEN), &
!              & KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, &
!              & KOUNT=ILREC,CDSTRING='SUTRLE:')    ! MPL 3.12.08
              CALL abor1(' SUTRLE:A LA PLACE DE MPL_RECV')
              ipos = 0
            ENDIF
          ENDDO
        ENDDO
      ENDIF
    ENDDO
!   CALL GSTATS(801,1)  ! MPL 4.12.08

!*    check received message length

    IF (ilrec /= ipos) THEN
      WRITE(nout,*)' SUTRLE: ILREC,IPOS,NCOMBLEN ',ilrec,ipos,ncombflen
      CALL abort_trans(' SUTRLE:RECEIVED MESSAGE LENGTH DOES NOT MATCH')
    ENDIF
  ENDIF

! Perform barrier synchronisation to guarantee all processors have
! completed communication for this jroc loop iteration

! CALL MPL_BARRIER(CDSTRING='SUTRLE:')      ! MPL 3.12.08
  CALL abor1(' SUTRLE:A LA PLACE DE MPL_BARRIER')

ENDDO

!*    copy data from pnm to rpnm

!CALL GSTATS(1803,0)   ! MPL 4.12.08
!cjfe OMP not efficient in that case
!cjfe!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jmloc,im,iofft,ioffg,jgl,iglloc,jn)
DO jmloc=1,d%NUMP
  im = d%MYMS(jmloc)
  iofft = d%NPMT(im)
  ioffg = d%NPMG(im)
  DO jgl=d%NLATLS(mysetw),d%NLATLE(mysetw)
    iglloc = jgl-d%NLATLS(mysetw)+1
    DO jn=1,r%NTMAX-im+2
      zpnm(jgl,iofft+jn) = pnm(ioffg+jn,iglloc)
    ENDDO
  ENDDO
ENDDO
!cjfe!$OMP END PARALLEL DO
!CALL GSTATS(1803,1) ! MPL 4.12.08

DEALLOCATE (zcombuf)

END SUBROUTINE sutrle
END MODULE sutrle_mod