! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- Meteo-France. ! ! This software is licensed under the terms of the Apache Licence Version 2.0 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. ! In applying this licence, ECMWF does not waive the privileges and immunities ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! MODULE SUTRLE_MOD CONTAINS SUBROUTINE SUTRLE(PNM,KGL,KLOOP) !**** *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 ! P.Towers : 10-01-12 Corrected over allocation of ZSNDBUF (XT4 fix) ! G.Mozdzynski: March 2011 Support 2D (RW,RV) initialisation of legendre coeffs ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPRD, JPIM USE MPL_MODULE ,ONLY : MPL_ALLREDUCE, MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, & & JP_NON_BLOCKING_STANDARD USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, MTAGLETR, NPRCIDS, NPRTRW, NPRTRV, & & MYSETV, MYSETW, NPROC USE TPM_FIELDS ,ONLY : F USE SET2PE_MOD ,ONLY : SET2PE USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE REAL(KIND=JPRD),INTENT(IN) :: PNM(:) INTEGER(KIND=JPIM),INTENT(IN) :: KGL INTEGER(KIND=JPIM),INTENT(IN) :: KLOOP ! LOCAL REAL(KIND=JPRD), ALLOCATABLE :: ZSNDBUFV(:),ZRCVBUFV(:,:) REAL(KIND=JPRD), ALLOCATABLE :: ZSNDBUFW(:,:),ZRCVBUFW(:,:) INTEGER(KIND=JPIM) :: IM, IPOS, & & IRECVSET, IRECV, ISEND, ISENDSET, ITAG,ISENDSIZE, IRECVSIZE, & & J, JM, JMLOC, JN, JV, JROC ,IOFFT, IOFFG, IGL, ISREQ, IRREQ INTEGER(KIND=JPIM) :: ISENDREQ(MAX(NPRTRW,NPRTRV)) INTEGER(KIND=JPIM) :: IRECVREQ(MAX(NPRTRW,NPRTRV)) INTEGER(KIND=JPIM) :: IGLVS(NPRTRV) INTEGER(KIND=JPIM) :: IGLVR(NPRTRV) INTEGER(KIND=JPIM) :: IPOSW(NPRTRW) ! ------------------------------------------------------------------ !* 0. Some initializations. ! --------------------- ITAG = MTAGLETR+KLOOP ! Perform barrier synchronisation to guarantee all processors have ! completed all previous communication IF( NPROC > 1 .AND. KLOOP ==1)THEN CALL GSTATS(783,0) CALL MPL_BARRIER(CDSTRING='SUTRLE:') CALL GSTATS(783,1) ENDIF ! ! First do communications in NPRTRV direction ! !* Calculate send buffer size IF(KGL > 0) THEN ISENDSIZE = R%NSPOLEG+1 ELSE ISENDSIZE=1 ENDIF ALLOCATE (ZSNDBUFV(ISENDSIZE)) ALLOCATE (ZRCVBUFV(R%NSPOLEG+1,NPRTRV)) !* copy data to be sent into zsndbufv ZSNDBUFV(1) = KGL IF(KGL > 0) THEN CALL GSTATS(1141,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(J) DO J=1,R%NSPOLEG ZSNDBUFV(J+1) = PNM(J) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1141,1) ENDIF IRREQ=0 DO JROC=1,NPRTRV-1 IRECV = MYSETV+JROC IF (IRECV > NPRTRV) IRECV = IRECV-NPRTRV IRECVSET = IRECV CALL SET2PE(IRECV,0,0,MYSETW,IRECVSET) IRREQ = IRREQ+1 CALL GSTATS(801,0) CALL MPL_RECV(ZRCVBUFV(:,IRECVSET),KSOURCE=NPRCIDS(IRECV), & &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& & KTAG=ITAG,CDSTRING='SUTRLE:') CALL GSTATS(801,1) ENDDO ISREQ = 0 DO JROC=1,NPRTRV-1 ISEND = MYSETV-JROC IF (ISEND <= 0) ISEND = ISEND+NPRTRV ISENDSET = ISEND CALL SET2PE(ISEND,0,0,MYSETW,ISENDSET) ISREQ = ISREQ+1 CALL GSTATS(801,0) CALL MPL_SEND(ZSNDBUFV(1:ISENDSIZE),KDEST=NPRCIDS(ISEND), & &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SUTRLE:') CALL GSTATS(801,1) ENDDO IF(ISREQ > 0) THEN CALL GSTATS(801,0) CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), & & CDSTRING='SUTRLE: WAIT') CALL GSTATS(801,1) ENDIF IF(IRREQ > 0) THEN CALL GSTATS(801,0) CALL MPL_WAIT(KREQUEST=IRECVREQ(1:IRREQ), & & CDSTRING='SUTRLE: WAIT') CALL GSTATS(801,1) ENDIF !* copy data from buffer to f%rpnm CALL GSTATS(1141,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JROC,IRECV,IRECVSET,IGL,JMLOC,IM,IOFFT,IOFFG,JN) DO JROC=1,NPRTRV-1 IRECV = MYSETV+JROC IF (IRECV > NPRTRV) IRECV = IRECV-NPRTRV IRECVSET = IRECV CALL SET2PE(IRECV,0,0,MYSETW,IRECVSET) IGL = ZRCVBUFV(1,IRECVSET) IGLVS(IRECVSET)=IGL IF( IGL > 0 )THEN DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) IOFFT = D%NPMT(IM) IOFFG = D%NPMG(IM) DO JN=1,R%NTMAX-IM+2 F%RPNM(IGL,IOFFT+JN) = ZRCVBUFV(1+IOFFG+JN,IRECVSET) ENDDO ENDDO ENDIF ENDDO !$OMP END PARALLEL DO DEALLOCATE (ZSNDBUFV) !* copy data from pnm to rpnm IGLVS(MYSETV)=KGL IF(KGL > 0) THEN ZRCVBUFV(1,MYSETV)=KGL ZRCVBUFV(2:R%NSPOLEG+1,MYSETV)=PNM(1:R%NSPOLEG) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JMLOC,IM,IOFFT,IOFFG,JN) DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) IOFFT = D%NPMT(IM) IOFFG = D%NPMG(IM) DO JN=1,R%NTMAX-IM+2 F%RPNM(KGL,IOFFT+JN) = PNM(IOFFG+JN) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1141,1) ! ! Now do communications in the NPRTRW direction ! !* Calculate send buffer size ISENDSIZE=0 DO JROC=1,NPRTRW-1 ISEND = MYSETW-JROC IF (ISEND <= 0) ISEND = ISEND+NPRTRW ISENDSET = ISEND CALL SET2PE(ISEND,0,0,ISENDSET,MYSETV) IPOS = 0 DO JM=0,R%NSMAX IF (ISENDSET == D%NPROCM(JM) ) IPOS = IPOS + R%NTMAX-JM+2 ENDDO ISENDSIZE = MAX(IPOS,ISENDSIZE) ENDDO ISENDSIZE=ISENDSIZE*NPRTRV+NPRTRV IRECVSIZE=ISENDSIZE IF( NPROC > 1 )THEN CALL GSTATS(801,0) CALL MPL_ALLREDUCE(IRECVSIZE,'MAX',CDSTRING='SUTRLE:') CALL GSTATS(801,1) ENDIF ALLOCATE (ZSNDBUFW(ISENDSIZE,NPRTRW)) ALLOCATE (ZRCVBUFW(IRECVSIZE,NPRTRW)) CALL GSTATS(1141,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JROC,ISEND,ISENDSET,IPOS,JV,IGL,JM,JN) DO JROC=1,NPRTRW-1 ISEND = MYSETW-JROC IF (ISEND <= 0) ISEND = ISEND+NPRTRW ISENDSET = ISEND CALL SET2PE(ISEND,0,0,ISENDSET,MYSETV) !* copy data to be sent into zsndbufw IPOS=0 DO JV=1,NPRTRV IPOS=IPOS+1 ZSNDBUFW(IPOS,ISENDSET) = IGLVS(JV) ENDDO DO JV=1,NPRTRV IGL = IGLVS(JV) IF( IGL > 0 )THEN DO JM=0,R%NSMAX IF (ISENDSET == D%NPROCM(JM) ) THEN DO JN=1,R%NTMAX-JM+2 IPOS = IPOS + 1 ZSNDBUFW(IPOS,ISENDSET) = ZRCVBUFV(1+D%NPMG(JM)+JN,JV) ENDDO ENDIF ENDDO ENDIF ENDDO IPOSW(ISENDSET)=IPOS ENDDO !$OMP END PARALLEL DO CALL GSTATS(1141,1) IRREQ = 0 DO JROC=1,NPRTRW-1 IRECV = MYSETW+JROC IF (IRECV > NPRTRW) IRECV = IRECV-NPRTRW IRECVSET = IRECV CALL SET2PE(IRECV,0,0,IRECVSET,MYSETV) !* receive message (if not empty) IRREQ = IRREQ+1 CALL GSTATS(801,0) CALL MPL_RECV(ZRCVBUFW(:,IRECVSET),KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& & KTAG=ITAG,CDSTRING='SUTRLE:') CALL GSTATS(801,1) ENDDO ISREQ = 0 DO JROC=1,NPRTRW-1 ISEND = MYSETW-JROC IF (ISEND <= 0) ISEND = ISEND+NPRTRW ISENDSET = ISEND CALL SET2PE(ISEND,0,0,ISENDSET,MYSETV) ISENDSIZE = IPOSW(ISENDSET) ISREQ = ISREQ+1 CALL GSTATS(801,0) CALL MPL_SEND(ZSNDBUFW(1:ISENDSIZE,ISENDSET),KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SUTRLE:') CALL GSTATS(801,1) ENDDO IF(ISREQ > 0) THEN CALL GSTATS(801,0) CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), & & CDSTRING='SUTRLE: WAIT') CALL GSTATS(801,1) ENDIF IF(IRREQ > 0) THEN CALL GSTATS(801,0) CALL MPL_WAIT(KREQUEST=IRECVREQ(1:IRREQ), & & CDSTRING='SUTRLE: WAIT') CALL GSTATS(801,1) ENDIF CALL GSTATS(1141,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JROC,IRECV,IRECVSET,IPOS,IGLVR,JV,IGL,JMLOC,IM,IOFFT,JN) DO JROC=1,NPRTRW-1 IRECV = MYSETW+JROC IF (IRECV > NPRTRW) IRECV = IRECV-NPRTRW IRECVSET = IRECV CALL SET2PE(IRECV,0,0,IRECVSET,MYSETV) !* copy data from buffer to f%rpnm IPOS=0 DO JV=1,NPRTRV IPOS=IPOS+1 IGLVR(JV)=ZRCVBUFW(IPOS,IRECVSET) ENDDO DO JV=1,NPRTRV IGL = IGLVR(JV) IF( IGL > 0 )THEN DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) IOFFT = D%NPMT(IM) DO JN=1,R%NTMAX-IM+2 IPOS = IPOS + 1 F%RPNM(IGL,IOFFT+JN) = ZRCVBUFW(IPOS,IRECVSET) ENDDO ENDDO ENDIF ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1141,1) DEALLOCATE (ZRCVBUFV) DEALLOCATE (ZSNDBUFW) DEALLOCATE (ZRCVBUFW) IF( NPROC > 1 .AND. KLOOP ==1)THEN CALL GSTATS(783,0) CALL MPL_BARRIER(CDSTRING='SUTRLE:') CALL GSTATS(783,1) ENDIF END SUBROUTINE SUTRLE END MODULE SUTRLE_MOD