! (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 TRGTOL_MOD IMPLICIT NONE PUBLIC TRGTOL PRIVATE TRGTOL_COMM CONTAINS SUBROUTINE TRGTOL(PGLAT, KF_FS, KF_GP, KF_SCALARS_G, KVSET, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, PGP2) !**** *TRGTOL * - head routine for transposition of grid point data from column ! structure to latitudinal. Reorganize data between ! grid point calculations and direct Fourier Transform !** Interface. ! ---------- ! *call* *trgtol_prolog(...) ! Explicit arguments : ! -------------------- ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! R. El Khatib *Meteo-France* ! Modifications. ! -------------- ! Original : 18-Aug-2014 from trgtol ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DISTR ,ONLY : D USE TRGL_MOD, ONLY: TRGL_BUFFERS, ALLOCATE_BUFFERS_CST, TRGL_PROLOG, ALLOCATE_BUFFERS_SR IMPLICIT NONE REAL(KIND=JPRB),INTENT(OUT) :: PGLAT(KF_FS,D%NLENGTF) INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM),INTENT(IN) :: KVSET(KF_GP) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP2(:,:,:) TYPE (TRGL_BUFFERS) :: YDBUFS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('TRGTOL',0,ZHOOK_HANDLE) YDBUFS%LLTRGTOL = .TRUE. CALL ALLOCATE_BUFFERS_CST(YDBUFS) CALL GSTATS(1805, 0) CALL TRGL_PROLOG(KF_FS, KF_GP, KVSET, YDBUFS) CALL GSTATS(1805, 1) CALL ALLOCATE_BUFFERS_SR(YDBUFS, KF_GP) CALL TRGTOL_COMM(PGLAT, KF_FS, KF_GP, KF_SCALARS_G, KVSET, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, PGP2, & & YDBUFS) IF (LHOOK) CALL DR_HOOK('TRGTOL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE TRGTOL SUBROUTINE TRGTOL_COMM(PGLAT, KF_FS, KF_GP, KF_SCALARS_G, KVSET, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, & & PGP2,YDBUFS) !**** *TRGTOL_COMM * - transposition of grid point data from column ! structure to latitudinal. Reorganize data between ! grid point calculations and direct Fourier Transform ! Purpose. ! -------- !** Interface. ! ---------- ! *call* *trgtol(...) ! Explicit arguments : ! -------------------- ! PGLAT - Latitudinal data ready for direct FFT (output) ! PGP - Blocked grid point data (input) ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original: 95-10-01 ! D.Dent : 97-08-04 Reorganisation to allow ! NPRTRV to differ from NPRGPEW ! : 98-06-17 add mailbox control logic (from TRLTOM) ! =99-03-29= Mats Hamrud and Deborah Salmond ! JUMP in FFT's changed to 1 ! KINDEX introduced and PCOMBUF not used for same PE ! 01-11-23 Deborah Salmond and John Hague ! LIMP_NOOLAP Option for non-overlapping message passing ! and buffer packing ! 01-12-18 Peter Towers ! Improved vector performance of GTOL_PACK,GTOL_UNPACK ! 03-04-02 G. Radnoti: call barrier always when nproc>1 ! 08-01-01 G.Mozdzynski: cleanup ! 09-01-02 G.Mozdzynski: use non-blocking recv and send ! R. El Khatib 09-Sep-2020 64 bits addressing for PGLAT ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_WAITANY, & & JP_BLOCKING_STANDARD, MPL_BARRIER, JP_BLOCKING_BUFFERED USE TPM_GEN ,ONLY : NTRANS_SYNC_LEVEL, NSTACK_MEMORY_TR USE TPM_DISTR ,ONLY : D, MTAGGL, NPRCIDS, MYPROC, NPROC USE TPM_TRANS ,ONLY : LGPNORM USE TRGL_MOD, ONLY: TRGL_BUFFERS, TRGL_VARS, TRGL_ALLOCATE_VARS, TRGL_ALLOCATE_HEAP_BUFFER, & & TRGL_INIT_VARS, TRGL_INIT_OFF_VARS, TGRL_COPY_ZCOMBUF, TGRL_COPY_PGLAT, & & TGRL_INIT_PACKING_VARS IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP REAL(KIND=JPRB),INTENT(OUT) :: PGLAT(KF_FS,D%NLENGTF) INTEGER(KIND=JPIM),INTENT(IN) :: KVSET(KF_GP) INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP2(:,:,:) TYPE(TRGL_BUFFERS), INTENT(INOUT), TARGET :: YDBUFS ! LOCAL VARIABLES TYPE(TRGL_VARS) :: YLVARS INTEGER(KIND=JPIM) :: IREQ_SEND(NPROC) INTEGER(KIND=JPIM) :: IREQ_RECV(NPROC) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IRECV INTEGER(KIND=JPIM) :: ISEND, ITAG, JL, JFLD, INS, INR, JNR INTEGER(KIND=JPIM) :: II,ILEN INTEGER(KIND=JPIM) :: IRECV_FLD_START,IRECV_FLD_END ! LOCAL ARRAYS REAL(KIND=JPRB), TARGET :: ZCOMBUFS_STACK(-1:YDBUFS%ISENDCOUNT,MERGE (YDBUFS%INSEND,0,NSTACK_MEMORY_TR/=0)) REAL(KIND=JPRB), TARGET :: ZCOMBUFR_STACK(-1:YDBUFS%IRECVCOUNT,MERGE (YDBUFS%INRECV,0,NSTACK_MEMORY_TR/=0)) REAL(KIND=JPRB), ALLOCATABLE, TARGET, SAVE :: ZCOMBUFS_HEAP(:,:) REAL(KIND=JPRB), ALLOCATABLE, TARGET, SAVE :: ZCOMBUFR_HEAP(:,:) REAL(KIND=JPRB), POINTER, CONTIGUOUS :: ZCOMBUFS(:,:) REAL(KIND=JPRB), POINTER, CONTIGUOUS :: ZCOMBUFR(:,:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR ! ------------------------------------------------------------------ !* 0. Some initializations ! -------------------- ASSOCIATE(KNSEND=>YDBUFS%INSEND, KNRECV=>YDBUFS%INRECV, KSENDTOT=>YDBUFS%ISENDTOT, & & KRECVTOT=>YDBUFS%IRECVTOT, KSEND=>YDBUFS%ISEND, KRECV=>YDBUFS%IRECV, & & KINDEX=>YDBUFS%IINDEX, KNDOFF=>YDBUFS%INDOFF) IF (NSTACK_MEMORY_TR == 0) THEN CALL TRGL_ALLOCATE_HEAP_BUFFER(ZCOMBUFS_HEAP, YDBUFS%ISENDCOUNT, YDBUFS%INSEND) CALL TRGL_ALLOCATE_HEAP_BUFFER(ZCOMBUFR_HEAP, YDBUFS%IRECVCOUNT, YDBUFS%INRECV) ! Now, force the OS to allocate this shared array right now, not when it starts to be used which ! is an OPEN-MP loop, that would cause a threads synchronization lock : IF (YDBUFS%INSEND > 0 .AND. YDBUFS%ISENDCOUNT >=-1) ZCOMBUFS_HEAP(-1,1)=HUGE(1._JPRB) ZCOMBUFS (-1:,1:) => ZCOMBUFS_HEAP ZCOMBUFR (-1:,1:) => ZCOMBUFR_HEAP ELSE ZCOMBUFS (-1:,1:) => ZCOMBUFS_STACK ZCOMBUFR (-1:,1:) => ZCOMBUFR_STACK ENDIF ITAG = MTAGGL IF (LHOOK) CALL DR_HOOK('TRGTOL_BAR',0,ZHOOK_HANDLE_BAR) CALL GSTATS_BARRIER(761) IF (LHOOK) CALL DR_HOOK('TRGTOL_BAR',1,ZHOOK_HANDLE_BAR) IF(.NOT.LGPNORM)THEN CALL GSTATS(803,0) ELSE CALL GSTATS(804,0) ENDIF IF (NTRANS_SYNC_LEVEL <= 0) THEN !...Receive loop......................................................... DO INR=1,KNRECV IRECV=KRECV(INR) CALL MPL_RECV(ZCOMBUFR(-1:KRECVTOT(IRECV),INR), KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD, KREQUEST=IREQ_RECV(INR), KTAG=ITAG, & & CDSTRING='TRGTOL_COMM: NON-BLOCKING IRECV' ) ENDDO ENDIF IF(.NOT.LGPNORM)THEN CALL GSTATS(803,1) ELSE CALL GSTATS(804,1) ENDIF CALL GSTATS(1805,0) YDBUFS%LLINDER = PRESENT(KPTRGP) YDBUFS%LLPGPONLY = PRESENT(PGP) CALL TRGL_ALLOCATE_VARS(YLVARS, KF_GP,KF_FS) CALL TRGL_INIT_VARS(YLVARS, KF_SCALARS_G, PGP, PGPUV, PGP3A, PGP3B, PGP2) CALL GSTATS(1805,1) ! Copy local contribution IF(KSENDTOT(MYPROC) > 0 )THEN CALL TRGL_INIT_OFF_VARS(YDBUFS,YLVARS,KVSET,KPTRGP,KF_GP) CALL GSTATS(1601,0) CALL TGRL_COPY_PGLAT(PGLAT, YDBUFS, YLVARS, PGP, PGPUV, PGP3A, PGP3B, PGP2) CALL GSTATS(1601,1) ENDIF ! Now overlapping buffer packing/unpacking with sends/waits ! Time as if all communications to avoid double accounting IF(.NOT.LGPNORM)THEN CALL GSTATS(803,0) ELSE CALL GSTATS(804,0) ENDIF !....Pack+send loop......................................................... CALL TGRL_INIT_PACKING_VARS(YDBUFS,YLVARS, KVSET, KF_GP, ZCOMBUFS) DO INS=1,KNSEND CALL TGRL_COPY_ZCOMBUF(YDBUFS, YLVARS, INS, ZCOMBUFS, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, PGP2) ENDDO DO INS=1,KNSEND ISEND=KSEND(INS) IF (NTRANS_SYNC_LEVEL <= 1) THEN CALL MPL_SEND(ZCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD, KREQUEST=IREQ_SEND(INS), KTAG=ITAG, & & CDSTRING='TRGTOL_COMM: NON-BLOCKING ISEND') ELSE CALL MPL_SEND(ZCOMBUFS(-1:KSENDTOT(ISEND),INS), KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_BLOCKING_BUFFERED, KTAG=ITAG, & & CDSTRING='TRGTOL_COMM: BLOCKING BUFFERED BSEND') ENDIF ENDDO ! Unpack loop......................................................... DO JNR=1,KNRECV IF (NTRANS_SYNC_LEVEL <= 0) THEN CALL MPL_WAITANY(KREQUEST=IREQ_RECV(1:KNRECV), KINDEX=INR, & & CDSTRING='TRGTOL_COMM: WAIT FOR ANY RECEIVES') ELSE INR = JNR IRECV=KRECV(INR) CALL MPL_RECV(ZCOMBUFR(-1:KRECVTOT(IRECV),INR), KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_BLOCKING_STANDARD, KTAG=ITAG, CDSTRING='TRGTOL_COMM: BLOCKING RECV' ) ENDIF IRECV=KRECV(INR) ILEN = KRECVTOT(IRECV)/KF_FS IRECV_FLD_START = ZCOMBUFR(-1,INR) IRECV_FLD_END = ZCOMBUFR(0,INR) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JL,II,JFLD) DO JL=1,ILEN II = KINDEX(KNDOFF(IRECV)+JL) DO JFLD=IRECV_FLD_START,IRECV_FLD_END PGLAT(JFLD,II) = ZCOMBUFR(JL+(JFLD-IRECV_FLD_START)*ILEN,INR) ENDDO ENDDO !$OMP END PARALLEL DO ENDDO IF (NTRANS_SYNC_LEVEL <= 1) THEN IF(KNSEND > 0) THEN CALL MPL_WAIT(KREQUEST=IREQ_SEND(1:KNSEND),CDSTRING='TRGTOL_COMM: WAIT FOR ISENDS') ENDIF ENDIF IF (NTRANS_SYNC_LEVEL >= 1) THEN CALL MPL_BARRIER(CDSTRING='TRGTOL_COMM: BARRIER AT END') ENDIF IF(.NOT.LGPNORM)THEN CALL GSTATS(803,1) ELSE CALL GSTATS(804,1) ENDIF CALL GSTATS_BARRIER2(761) END ASSOCIATE END SUBROUTINE TRGTOL_COMM END MODULE TRGTOL_MOD