source: LMDZ5/trunk/libf/phylmd/rrtm/sutrle_mod.F90 @ 4771

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