! (C) Copyright 2024- ECMWF. ! ! 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 GPNORM_TRANS_CTLTL_MOD CONTAINS SUBROUTINE GPNORM_TRANS_CTLTL(PGP,KFIELDS,KPROMA,PAVE,PW) !**** *GPNORM_TRANS_CTL* - calculate grid-point norms ! simplified version to be projected to adjoint ! Purpose. ! -------- ! calculate grid-point norms using a 2 stage (NPRTRV,NPRTRW) communication rather ! than an approach using a more expensive global gather collective communication !** Interface. ! ---------- ! CALL GPNORM_TRANS_CTL(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! PMIN - minimum (input/output) ! PMAX - maximum (input/output) ! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX ! is uniquely false ! ! Author. ! ------- ! F. Vana after gpnorm_trans_ctl_mod ! Modifications. ! -------------- ! Original : September 2024 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD !ifndef INTERFACE USE TPM_GEN ,ONLY : NOUT USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : LGPNORM, NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRCIDS, NPRTRV, NPRTRW, MYSETV, MYSETW USE TPM_GEOMETRY ,ONLY : G USE TRGTOL_MOD ,ONLY : TRGTOL USE SET2PE_MOD ,ONLY : SET2PE USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, JP_BLOCKING_STANDARD USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PAVE(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA REAL(KIND=JPRD) ,INTENT(IN) :: PW(R%NDGL) !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: IUBOUND(4) INTEGER(KIND=JPIM) :: IVSET(KFIELDS) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETG(:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZGTF(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVE(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVEG(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZSND(:) REAL(KIND=JPRD),ALLOCATABLE :: ZRCV(:) INTEGER(KIND=JPIM) :: J,JGL,IGL,JL,JF,IF_GP,IF_SCALARS_G,IF_FS,JSETV,JSETW,IWLATS INTEGER(KIND=JPIM) :: IPROC,ITAG,ILEN,ILENR,IBEG,IEND,IND ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS_CTLTL',0,ZHOOK_HANDLE) ! Set defaults NPROMA = KPROMA NGPBLKS = (D%NGPTOT-1)/NPROMA+1 ! Consistency checks IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTLTL:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('GPNORM_TRANS_CTLTL:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFIELDS) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTLTL:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFIELDS CALL ABORT_TRANS('GPNORM_TRANS_CTLTL:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTLTL:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('GPNORM_TRANS_CTLTL:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF_GP=KFIELDS IF_SCALARS_G=0 IF_FS=0 DO J=1,KFIELDS IVSET(J)=MOD(J-1,NPRTRV)+1 IF(IVSET(J)==MYSETV)THEN IF_FS=IF_FS+1 ENDIF ENDDO ALLOCATE(IVSETS(NPRTRV)) IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 ENDDO ALLOCATE(IVSETG(NPRTRV,MAXVAL(IVSETS(:)))) IVSETG(:,:)=0 IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 IVSETG(IVSET(J),IVSETS(IVSET(J)))=J ENDDO ALLOCATE(ZGTF(IF_FS,D%NLENGTF)) IF (SIZE(ZGTF) > 0) ZGTF(:,:)=0._JPRB ! force allocation right here, not inside an omp region below LGPNORM=.TRUE. CALL TRGTOL(ZGTF,IF_FS,IF_GP,IF_SCALARS_G,IVSET,PGP=PGP) LGPNORM=.FALSE. IBEG=1 IEND=D%NDGL_FS ALLOCATE(ZAVE(IF_FS,IBEG:IEND)) IF( IF_FS > 0 )THEN ZAVE(:,:)=0.0_JPRB ! FIRST DO SUMS IN EACH FULL LATITUDE CALL GSTATS(1429,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JGL,IGL,JF,JL) DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 !CDIR NOLOOPCHG DO JF=1,IF_FS !DIR$ NEXTSCALAR DO JL=1,G%NLOEN(IGL) ZAVE(JF,JGL)=ZAVE(JF,JGL)+ZGTF(JF,D%NSTAGTF(JGL)+JL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1429,1) DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 DO JF=1,IF_FS ZAVE(JF,JGL)=ZAVE(JF,JGL)*REAL(PW(IGL),JPRB)/G%NLOEN(IGL) ENDDO ENDDO ENDIF ! IT IS IMPORTANT THAT SUMS ARE NOW DONE IN LATITUDE ORDER ALLOCATE(ZAVEG(R%NDGL,KFIELDS)) ZAVEG(:,:)=0.0_JPRB DO JF=1,IF_FS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 ZAVEG(IGL,IVSETG(MYSETV,JF))=ZAVEG(IGL,IVSETG(MYSETV,JF))+ZAVE(JF,JGL) ENDDO ENDDO ! RECEIVE ABOVE FROM OTHER NPRTRV SETS FOR SAME LATS BUT DIFFERENT FIELDS ITAG=123 CALL GSTATS(815,0) IF( MYSETV==1 )THEN DO JSETV=2,NPRTRV ILEN=(D%NDGL_FS)*IVSETS(JSETV) IF(ILEN > 0)THEN ALLOCATE(ZRCV(ILEN)) CALL SET2PE(IPROC,0,0,MYSETW,JSETV) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='GPNORM_TRANS_CTLTL:V') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS_CTLTL:ILENR /= ILEN') ENDIF IND=0 DO JF=1,IVSETS(JSETV) DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,IVSETG(JSETV,JF))=ZRCV(IND) ENDDO ENDDO DEALLOCATE(ZRCV) ENDIF ENDDO ELSE ILEN=(D%NDGL_FS)*IVSETS(MYSETV) IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,MYSETW,1) ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,IF_FS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZSND(IND)=ZAVEG(IGL,IVSETG(MYSETV,JF)) ENDDO ENDDO CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS_CTLTL:V') DEALLOCATE(ZSND) ENDIF ENDIF ! FINALLY RECEIVE CONTRIBUTIONS FROM OTHER NPRTRW SETS IF( MYSETV == 1 )THEN IF( MYSETW == 1 )THEN DO JSETW=2,NPRTRW IWLATS=D%NULTPP(JSETW) ILEN=IWLATS*KFIELDS IF(ILEN > 0 )THEN ALLOCATE(ZRCV(ILEN)) CALL SET2PE(IPROC,0,0,JSETW,1) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='GPNORM_TRANS_CTLTL:W') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS_CTLTL:ILENR /= ILEN') ENDIF IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IWLATS IGL = D%NPTRLS(JSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,JF)=ZRCV(IND) ENDDO ENDDO DEALLOCATE(ZRCV) ENDIF ENDDO ELSE IWLATS=D%NULTPP(MYSETW) ILEN=IWLATS*KFIELDS IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,1,1) ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IWLATS IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZSND(IND)=ZAVEG(IGL,JF) ENDDO ENDDO CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS_CTLTL:W') DEALLOCATE(ZSND) ENDIF ENDIF ENDIF CALL GSTATS(815,1) IF( MYSETW == 1 .AND. MYSETV == 1 )THEN PAVE(:)=0.0_JPRB DO JGL=1,R%NDGL PAVE(:)=PAVE(:)+ZAVEG(JGL,:) ENDDO ENDIF DEALLOCATE(ZGTF) DEALLOCATE(ZAVE) DEALLOCATE(ZAVEG) DEALLOCATE(IVSETS) DEALLOCATE(IVSETG) IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS_CTLTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE GPNORM_TRANS_CTLTL END MODULE GPNORM_TRANS_CTLTL_MOD